خطأ في كود الترحيل

[saif_5]

السلام عليكم

 

عندي هذا الملف فيه خطأ بالكود اذا ممكن احد يتكرم ويشوفه لي 

شكرا لكم :)

الترحيل.zip

[ابراهيم الحداد]

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

الكود بعد التعديل

Sub saif()
Dim sh As Worksheet
LR = Cells(Rows.Count, 1).End(xlUp).Row
For Each sh In ThisWorkbook.Worksheets
For r = 2 To LR
If sh.Name = "البرنامج" Then GoTo 2
If Sheets("البرنامج").Cells(r, 1).Value <> Empty Then
If Sheets("البرنامج").Cells(r, 1).Value = sh.Name Then
Sheets("البرنامج").Range("D" & r & ":M" & r).Copy
qq = sh.Cells(100000, 1).End(xlUp).Row + 1
sh.Range("a" & qq).PasteSpecial xlPasteValues
End If
End If
Next
2
Next
Application.CutCopyMode = False
Application.ScreenUpdating = True
End Sub

 

[saif_5]

شكرا لك يا استاذ زيزو .. الله يجزاك الجنة 

طيب اذا الشيتات اللي عايز ارحل لهااكثر من 2 هل اغير شي على الكود ؟

[ابراهيم الحداد]

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

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

تم تعديل يوليو 20, 2017 بواسطه زيزو العجوز

[عبدللرحيم]

جزيل الشكر للخبير 

زيزو العجوز

برجاء تعديل الكود لفحص عدم تكرار الترحيل

 

[saif_5]

في ٢٠‏/٧‏/٢٠١٧ at 23:09, زيزو العجوز said:

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

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

شكرا لك يا استاذ زيزو 

وهل فيه امكانية عدم تكرار الترحيل  مثل ما قال الاخ عبدالرحيم ؟

[ابراهيم الحداد]

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

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

 

[saif_5]

السلام عليكم يا استاذ زيزو

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

الترحيل 1.zip

[ابراهيم الحداد]

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

استخدم هذا الكود

Sub saif2()
Dim LR As Long, LS As Long
Dim sh As Worksheet
For Each sh In ThisWorkbook.Worksheets
If sh.Name <> "البرنامج" Then
LS = sh.Cells(Rows.Count, 11).End(xlUp).Row
sh.Range("K" & LS & ": L" & LS).Copy
LR = Sheets("البرنامج").Cells(Rows.Count, 16).End(xlUp).Row + 1
Sheets("البرنامج").Range("P" & LR).PasteSpecial xlPasteValues
End If
Next sh

Application.CutCopyMode = False
Application.ScreenUpdating = True
End Sub

 

[saif_5]

السلام عليكم يا استاذ زيزو

 

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

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

جزاك الله خير بغلبك معي  :)

[ابراهيم الحداد]

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

اعتقد انك تقصد هذا الكود

Sub saif2()
Dim LR As Long, LS As Long, R As Long
Dim sh As Worksheet
LR = Sheets("البرنامج").Cells(Rows.Count, 1).End(xlUp).Row
For Each sh In ThisWorkbook.Worksheets
LS = sh.Cells(Rows.Count, 11).End(xlUp).Row
For R = 2 To LR
If sh.Name = Sheets("البرنامج").Range("A" & R) Then
Sheets("البرنامج").Range("P" & R) = sh.Range("K" & LS)
Sheets("البرنامج").Range("Q" & R) = sh.Range("L" & LS)
End If
Next
Next sh
Application.ScreenUpdating = True
End Sub

 

[saif_5]

جزاك الله خير يا استاذ زيزو

هو هذا المطلوب

طيب طلب اخير اذا تكرمت .. كود يحسب لي العمود K و L   بنفس الدالة اللي حاسبهم يدوي في الشيتات اللي اسمائهم 1010 و 1020 تلقائي بمجرد ما ارحل البيانات من  A الى  J