تعديل على كود ترحيل بيانات من شيت الى شيت أخر

[ابو عبدالرحمن البغدادي]

السلام عليكم : حياكم الله - من خلال فيديو تعليمي تم اضافة كود 

المطلوب يرحمكم الله

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

 

تعديل كود ترحيل من شيت الى شيت اخر.rar

[الصـقر]

اخى الكريم

على حسب فهمى لطلبك ولو انك برأى مصعب الامور على نفسك

المهم ادخل على الموديول رقم 3

استبدل الكود الموجود بالتالى

Sub abd()
Application.ScreenUpdating = False
For Each f In Range("d2:d10000")
If f <> "" Then
x = f.Value
Union(Range(f.Offset(0, -3), f.Offset(0, -1)), Range(f.Offset(0, 1), f.Offset(0, 1))).Copy
ir = Sheets(x).Range("a" & Rows.Count).End(xlUp).Row
Sheets(x).Range("a" & ir + 1).PasteSpecial xlPasteValues
Range(f.Offset(0, 2), f.Offset(0, 2)).Copy
Sheets(x).Range("f" & ir + 1).PasteSpecial xlPasteValues
End If
Next f
Sheets(1).Activate
Application.CutCopyMode = False
Application.ScreenUpdating = True
End Sub

تقبل تحياتى

[ابو عبدالرحمن البغدادي]

السلام عليكم - مرحبا استاذ (الصقر)

اشكرك - جزيت خيرا

الحمد لله تم الترحيل ، فقط استاذنا :

مسح البيانات عند الترحيل 

[الصـقر]

تفضل الكود

Sub abd()
Application.ScreenUpdating = False
For Each f In Range("d2:d10000")
If f <> "" Then
x = f.Value
Union(Range(f.Offset(0, -3), f.Offset(0, -1)), Range(f.Offset(0, 1), f.Offset(0, 1))).Copy
ir = Sheets(x).Range("a" & Rows.Count).End(xlUp).Row
Sheets(x).Range("a" & ir + 1).PasteSpecial xlPasteValues
Range(f.Offset(0, 2), f.Offset(0, 2)).Copy
Sheets(x).Range("f" & ir + 1).PasteSpecial xlPasteValues
End If
Next f
Application.CutCopyMode = False
Range("a2:f100000").ClearContents
Sheets(1).Activate
Application.ScreenUpdating = True
End Sub

تقبل تحياتى

[ابو عبدالرحمن البغدادي]

جزيت خيرا

تمام

مشكور