مساعدة في ترحيل قيم خلايا من ورقة الى اخرى

[عبدالفتاح محمد]

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

المطلوب في الملف

‫ترحيل2 - نسخة.xlsm

تم تعديل مايو 16, 2019 بواسطه عبدالفتاح محمد
اضافة تفصيل

[سليم حاصبيا]

لا جاجة للحاقات التكراراية 

استبدل الكود بهذا

Option Explicit
Sub transferData()

Dim LR1 As Long
Dim LR2 As Long
Dim sh1 As Worksheet: Set sh1 = Sheets("ورقة1")
Dim sh2 As Worksheet: Set sh2 = Sheets("ورقة2")

LR1 = sh1.Range("A" & Rows.Count).End(3).Row
LR2 = sh2.Range("A" & Rows.Count).End(3).Row + 1
 If LR2 = 2 Then LR2 = 1
 sh1.Cells(1, 1).Resize(LR1, 4).Copy
 
 With sh2.Cells(LR2, 1)
 .PasteSpecial 12
 .PasteSpecial -4122
 End With
Application.CutCopyMode = False
End Sub

الملف مرفق

 

TARHIL_SALIM.xlsm

[عبدالفتاح محمد]

بارك الله فيك يا خي الكود يعمل بشكل رائع 

تم تعديل مايو 16, 2019 بواسطه عبدالفتاح محمد

[عبدالفتاح محمد]

عندي استفسار اخير  عندما يتم الترحيل خصوصا بالفاتورة يتم ترحيل الارقام المتسلسلة 1و2و3 ويتاجاهل الفارغة في الكود الاول اما كودك  فلا  هل من حل بحيث يتم ترحيل  الفاتورة التي تحتوي  على ارقام متسلسلة  فقط وتجاهل الصفوف التي لا تحتوي على ارقام تسلسلية 

[سليم حاصبيا]

تم معالجة الامر

Option Explicit
Sub transferData_New()

Dim LR1 As Long
Dim LR2 As Long
Dim sh1 As Worksheet: Set sh1 = Sheets("ورقة1")
Dim sh2 As Worksheet: Set sh2 = Sheets("ورقة2")
Dim x%
LR1 = sh1.Range("A" & Rows.Count).End(3).Row
LR2 = sh2.Range("A" & Rows.Count).End(3).Row + 1

 If LR2 = 2 Then LR2 = 1

 x = sh1.Range("a1:D" & LR1). _
 Find("", after:=sh1.Cells(13, 1)).Row - 1
 
 sh1.Cells(1, 1).Resize(x, 4).Copy
 
  With sh2.Cells(LR2, 1)
 .PasteSpecial 12
 .PasteSpecial -4122
 End With
 sh1.Cells(LR1, 1).Resize(, 4).Copy
  
  With sh2.Cells(x + 1, 1)
 .PasteSpecial 12
 .PasteSpecial -4122
 .Cells(x - 15, 4).Value = _
  sh1.Cells(x + 1, 4).Value
 End With

Application.CutCopyMode = False
End Sub

 

 

[عبدالفتاح محمد]

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

[سليم حاصبيا]

48 دقائق مضت, عبدالفتاح محمد said:

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

ورد خطأ بسيط في الكود (سطر زيادة )

 الكود من جديد

Option Explicit
Sub transferData_New()

Dim LR1 As Long
Dim LR2 As Long
Dim sh1 As Worksheet: Set sh1 = Sheets("ورقة1")
Dim sh2 As Worksheet: Set sh2 = Sheets("ورقة2")
Dim x%
LR1 = sh1.Range("A" & Rows.Count).End(3).Row
LR2 = sh2.Range("A" & Rows.Count).End(3).Row + 1

 If LR2 = 2 Then LR2 = 1

 x = sh1.Range("a1:D" & LR1). _
 Find("", after:=sh1.Cells(13, 1)).Row - 1
 
 sh1.Cells(1, 1).Resize(x, 4).Copy
 
  With sh2.Cells(LR2, 1)
 .PasteSpecial 12
 .PasteSpecial -4122
 End With
 sh1.Cells(LR1, 1).Resize(, 4).Copy
  
  With sh2.Cells(x + 1, 1)
 .PasteSpecial 12
 .PasteSpecial -4122
Rem .Cells(x - 15, 4).Value = _
  sh1.Cells(x + 1, 4).Value
 End With

Application.CutCopyMode = False
End Sub

 

[عبدالفتاح محمد]

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