طلب كود ترحيل لملف شيكات

[sayid]

السلام عليكم ورحمة الله وبركاتة 

الى جميع الاخوة الاعضاء شكرا لكم جميعا علي هذا المنتدي الاكثر من رائع 

الموضوع بسيط جدا انا عندي ملف شيكات عاوز اعمل ترحيل بيانات الشيك من ( تاريخ - الاسم - المبلغ - البيان ) من ورقة شيك البنك المحدد الي ورقة الشيكات المنصرفة في الجدول الخاص بشيكات نفس البنك لاني بستعمل الملف تقريبا يومياً واريد الاحتفاظ بالشيكات المنصرفة للرجوع لها فيما بعد

بس في الحقيقة انا لا افقه شيء في المعدلات والاكواد بس أمل عمالقة المنتدي والاخوة الاعضاء المساعدة ولكم جزيل الشكر

تحياتي

‫الشيكات 2017.rar

[ياسر خليل أبو البراء]

وعليكم السلام ورحمة الله وبركاته

جرب الكود التالي عله يفي بالغرض إن شاء الله

Sub TransferBankDetails()
'YasserKhalil *** 06-06-2017
'---------------------------
    Dim ws      As Worksheet
    Dim sh      As Worksheet
    Dim fn      As Variant
    Dim lr      As Long
    
    Application.ScreenUpdating = False
        Set sh = ThisWorkbook.Sheets("الشيكات المنصرفة")
        For Each ws In ThisWorkbook.Worksheets
            If Left(ws.Name, 5) = "البنك" Then
                fn = Application.Match("شيكات " & ws.Name, sh.Rows(1), 0)
                If Not IsError(fn) Then
                    lr = sh.Cells(Rows.Count, fn).End(xlUp).Row + 1
                    sh.Cells(lr, fn).Value = ws.Range("B2").Value
                    sh.Cells(lr, fn + 1).Value = ws.Range("D7").Value
                    sh.Cells(lr, fn + 2).Value = ws.Range("A8").Value
                    sh.Cells(lr, fn + 4).Value = ws.Range("F10").Value
                End If
            End If
        Next ws
    Application.ScreenUpdating = True
    
    MsgBox "Done...", 64
End Sub

 

[sayid]

56 دقائق مضت, ياسر خليل أبو البراء said:

وعليكم السلام ورحمة الله وبركاته

جرب الكود التالي عله يفي بالغرض إن شاء الله

Sub TransferBankDetails()
'YasserKhalil *** 06-06-2017
'---------------------------
    Dim ws      As Worksheet
    Dim sh      As Worksheet
    Dim fn      As Variant
    Dim lr      As Long
    
    Application.ScreenUpdating = False
        Set sh = ThisWorkbook.Sheets("الشيكات المنصرفة")
        For Each ws In ThisWorkbook.Worksheets
            If Left(ws.Name, 5) = "البنك" Then
                fn = Application.Match("شيكات " & ws.Name, sh.Rows(1), 0)
                If Not IsError(fn) Then
                    lr = sh.Cells(Rows.Count, fn).End(xlUp).Row + 1
                    sh.Cells(lr, fn).Value = ws.Range("B2").Value
                    sh.Cells(lr, fn + 1).Value = ws.Range("D7").Value
                    sh.Cells(lr, fn + 2).Value = ws.Range("A8").Value
                    sh.Cells(lr, fn + 4).Value = ws.Range("F10").Value
                End If
            End If
        Next ws
    Application.ScreenUpdating = True
    
    MsgBox "Done...", 64
End Sub

 

الاخ ياسر اشكرك علي سرعة الاستجابة والمجهود اللي انت عملته

بس المشكلة اني لا اعرف كيف التعامل مع الاكواد ولا كيفية تركيبها ومش عارف المفروض اعمل ايه

استأذنك لو تكرمت لو تعدل على الملف وترفقه اكون شاكر ليك ولو امكن تفهمني كمان ازاي اركب الكود من باب العلم بالشيء 

تحياتي ليك

[ياسر خليل أبو البراء]

شاهد الفيديو التالي لعله يفيدك إن شاء الله

 

[sayid]

الاخ المحترم / ياسر

بشكرك على الفيديو انا فعلا اتعلمت منه وحاولت التطبيق علي ملف الشيكات بس فية مشكلة هى لما بعمل ترحيل يتم ترحيل جميع الشيكات في نفس الوقت يعني لما بعمل شيك في البنك الاهلي يتم ترحيل الشيكات الاخرى بدون داعي وتكرارها وفحاولت انى اعدل على الملف شوية 

فعملت ورقة واحدة لكل بنك حتي يتم ترحيل فقط الشيك الذي اريد بدون الشيكات الاخري فوضعت الكود الذي اعطيتني فلم ينفع 

لذلك أمل منك مراجعة الملف ثم عمل كود الترحيل المناسب لكل شيك الى الورقة الخاصة به

تحياتي ليك واسف على الاطالة

‫الشيكات 2017 - 1.rar

[ياسر خليل أبو البراء]

استخدم الكود التالي في هذه الحالة لكل البنوك .. الكود مرن وكل ما عليك هو ربطه بالصورة الموجودة في أوراق البنوك

Sub TransferBankDetails()
'YasserKhalil *** 07-06-2017
'---------------------------
    Dim ws      As Worksheet
    Dim sh      As Worksheet
    Dim lr      As Long
    
    Application.ScreenUpdating = False
        Set ws = ActiveSheet
        Set sh = ThisWorkbook.Sheets("شيكات " & ActiveSheet.Name)
        If Left(ws.Name, 5) <> "البنك" Then Exit Sub
        
        lr = sh.Cells(Rows.Count, 1).End(xlUp).Row + 1
        sh.Cells(lr, 1).Value = ws.Range("B2").Value
        sh.Cells(lr, 2).Value = ws.Range("D7").Value
        sh.Cells(lr, 3).Value = ws.Range("A8").Value
        sh.Cells(lr, 5).Value = ws.Range("F10").Value
    Application.ScreenUpdating = True
    
    MsgBox "Done...", 64
End Sub

 

[sayid]

اشكرك جزيلا اخ / ياسر     

الكود ظبط وتمام جدا واوفى بالمطلوب ومعلش تعبتك معايا 

بس فيه حاجة تانية لما عملت حماية لورقة كشف البنك وجيت عملت ترحيل لشيك تظهر رسالة خطا 

انا عايز اعمل حماية للكشف عشان محدش يمسح منه حاجة 

ياريت مساعدتك في الموضوع ده

تم تعديل يونيو 6, 2017 بواسطه sayid

[ياسر خليل أبو البراء]

بعد هذا السطر

 Set sh = ThisWorkbook.Sheets("شيكات " & ActiveSheet.Name)

قم بوضع سر لفك الحماية بهذا الشكل

sh.Unprotect "Pass"

حيث الكلمة Pass التي بين قوسي التنصيص هي كلمة السر

وفي نهاية الكود قم بإرجاع الحماية مرة أخرى بعد هذا السطر

sh.Cells(lr, 5).Value = ws.Range("F10").Value

ضع السطر التالي

ws.Protect "Pass"

 

[sayid]

حياك الله اخي ياسر وشكرا على الاستجابة

عملت اللي قلت علية ولكن لا يوجد حماية على اي ورقة واقدر امسح اي شي عادي

[ياسر خليل أبو البراء]

هل الخلايا محمية ...

من المفترض قبل وضع حماية للورقة أن تقوم بتحديد الخلايا المطلوبة ثم كليك يمين ثم Format Cells واذهب للتبويب الأخير وتأكد من وجود علامة صح بجانب الخيار Locked والخيار Hidden

[sayid]

مشكووورر يا استاذ ياسر على المجهود المبذول 

واسف على التاخير لظروف العمل 

وجزالك الله كل خير

[sayid]

السلام عليكم اخ ياسر 

معلش حصل مشكلة فى الملف هى انه بعد ايام قلية من العمل علية عند عمل ترحيل للشيك لا يتم الترحيل الا من صفحة البنك الفرنسي فقط ومش عارف ايه المشكلة

الملف الجديد بالمرفقات

‫الشيكات 2017.rar

[ياسر خليل أبو البراء]

وعليكم السلام أخي الكريم

في الحقيقة لا أحب تغيير هيكلة الملفات المرفقة حيث أن ذلك يلزمه تغير في الموضوع ...

في الملف الجديد لاحظت أنك قمت بتحويل النطاقات إلى جداول في أوراق العمل "شيكات البنك العربي" و "شيكات البنك الاهلي" بينما ورقة العمل "شيكات البنك الفرنسي" لم يتم تحويلها لجدول ....

انظر في الأوراق المذكورة في نهايتها ستجد بيانات في آخر الجدول وليس داخل الجدول .. لذا أولاً يجب ضبط الملف ومسح البيانات الموجودة في آخر الأوراق والتي توجد خارج نطاق الجدول .. وأيضاً قم بتحويل النطاق في آخر ورقة "شيكات البنك الفرنسي" إلى جدول لتكون الأوراق بنفس الهيكل ... ثم قم بحذف الأكواد التي لديك كلها واستخدم كود واحد فقط الذي سأدرجه لك الآن ...

وها هو الكود .. وبعد وضعه في موديول قم بربط الأزرار الموجودة في الأوراق المعنية بهذا الكود فقط ... لا تقم بنسخ الكود ثلاثة مرات كما هو مرفق في ملفك بل استخدم الكود مرة واحدة فقط للثلاثة أوراق

Option Explicit

Sub TransferBankDetails()
    Dim ws          As Worksheet
    Dim sh          As Worksheet
    Dim lr          As Long
    
    Application.ScreenUpdating = False
        Set ws = ActiveSheet
        Set sh = ThisWorkbook.Sheets("شيكات " & ActiveSheet.Name)
        If Left(ws.Name, 5) <> "البنك" Then Exit Sub
        
        lr = sh.Cells(LastTableRow(sh), 1).End(xlUp).Row + 1
        sh.Cells(lr, 1).Value = ws.Range("B2").Value
        sh.Cells(lr, 2).Value = ws.Range("D7").Value
        sh.Cells(lr, 3).Value = ws.Range("A8").Value
        sh.Cells(lr, 5).Value = ws.Range("F10").Value
    Application.ScreenUpdating = True
    
    MsgBox "Done...", 64
End Sub

Function LastTableRow(Optional ByVal TableSheet As Worksheet) As Long
    Dim Table       As ListObject
    Dim LastRow     As Long

    If TableSheet Is Nothing Then
        If ActiveSheet Is Nothing Then Exit Function
        Set TableSheet = ActiveSheet
    End If

    For Each Table In TableSheet.ListObjects
        If Table.DataBodyRange Is Nothing Then
            LastRow = WorksheetFunction.Max(Table.InsertRowRange.Row + 1, LastRow)
        Else
            LastRow = WorksheetFunction.Max(Table.ListRows(Table.ListRows.Count).Range.Row, LastRow)
        End If
        If Table.ShowTotals Then LastRow = LastRow + 1
    Next Table

    LastTableRow = LastRow
End Function

 

[sayid]

شكرا اخ ياسر على الرد 

فعلا كلامك صحيح المشكلة حصلت بعد اما عملت الجدول بس دلوقتي عملت زي ما انت قلت وركبت الكود وكله بقي تمام التمام تسلم ايديك 

وشكرا على طول بالك معايا ربنا يكرمك  

[ياسر خليل أبو البراء]

بارك الله فيك أخي الكريم سيد

والحمد لله أن تم المطلوب على خير ، والحمد لله الذي بنعمته تتم الصالحات

تقبل وافر تقديري واحترامي وكل عام وأنت بخير

[akhmedtaia]

بارك الله لك