ترحيل مماثل

[نصر الإيمان]

السلام عليكم

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

 

ترحيل مماثل.xlsm

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

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

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

Sub زر_ترحيل()
Dim ws As Worksheet, Sh As Worksheet
Set ws = Sheets("Names Data")
Set Sh = Sheets("الترحيل")
ws.Range("A10:C" & ws.Range("C" & Rows.Count).End(xlUp).Row).Copy
Sh.Range("A10").PasteSpecial xlPasteValues
Application.CutCopyMode = False
End Sub

 

[نصر الإيمان]

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

عاجز عن شكرك

طيب معلشي لو عاوز ارحل عمود واحد فقط وليكن الثالث ( الإسم) ماذا سيكون الكود

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

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

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

Sub زر_ترحيل()
Dim ws As Worksheet, Sh As Worksheet
Set ws = Sheets("Names Data")
Set Sh = Sheets("الترحيل")
ws.Range("C10:C" & ws.Range("C" & Rows.Count).End(xlUp).Row).Copy
Sh.Range("C10").PasteSpecial xlPasteValues
Application.CutCopyMode = False
End Sub

 

[جمعة العوامي]

بارك الله فيك ...

[نصر الإيمان]

بارك الله فيك استاذي!!! عاجز عن شكرك

[نصر الإيمان]

طب حضرتك لو عاوز الترحيل " كل ثلاثة صفوف يتم ترك صف" وهو الذي باللون الأحمر كما بالصورة

أنا آسف تعبت حضرتك معايا

 

ترحيل مماثل1.xlsm

تم تعديل أبريل 8, 2018 بواسطه نصر الإيمان

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

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

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

Sub زر_ترحيل()
Dim ws As Worksheet, Sh As Worksheet
Dim C As Range
Dim x As Integer, R As Integer, LR As Integer
Set ws = Sheets("Names Data")
Set Sh = Sheets("الترحيل")
Application.ScreenUpdating = False
R = 10
LR = ws.Range("C" & Rows.Count).End(xlUp).Row
Do While R < LR
For Each C In Sh.Range("A10:A" & ws.Range("C" & Rows.Count).End(xlUp).Row)
If C.Interior.ColorIndex <> 3 Then
C.Value = ws.Range("A" & R).Value
C.Offset(0, 1).Value = ws.Range("B" & R).Value
C.Offset(0, 2).Value = ws.Range("C" & R).Value
End If
R = R + 1
Next
Loop
Application.ScreenUpdating = True
End Sub

 

[نصر الإيمان]

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

لكن الأرقام أريدها كاملـــه(1 -2 3) فراغ (4 -5 - 6)   "مع وجود صف فارغ بين كل ثلاثة ارقام"

            حضرتك عملتها ( 1 - 2 -3) فراغ ( 5 -6 - 7) 

تم تعديل أبريل 9, 2018 بواسطه نصر الإيمان

[نصر الإيمان]

تسلم استاذ زيزو من كل سوء

لكن يوجد ملاحظه : عند عندم وجود اللون الأحمر لا يتم عمل الكود ( هل ينفع التعديل بدون وجود اللون الأحمر) كما بالصورة 

مع وجود صف فارغ بين كل 3 صفوف (مع عدم تأثير تسلسل الأرقام بهذا الصف الفارغ)

 

 

تم تعديل أبريل 9, 2018 بواسطه نصر الإيمان

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

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

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

و اربط الزر بالكود الثانى وليس الاول

Sub Trans1()
Dim ws As Worksheet, Sh As Worksheet
Dim C As Range, x As Integer, y As Integer, z As Integer
Application.ScreenUpdating = False
Set ws = Sheets("Names Data")
Set Sh = Sheets("الترحيل")
z = WorksheetFunction.Max(ws.Range("A10:A" & ws.Range("A" & Rows.Count).End(xlUp).Row))
For Each C In Sh.Range("A10:A2000")
x = C.Row - 9
y = x Mod 4
If y <> 0 Then
p = p + 1
If p > z Then Exit Sub
C.Value = p
End If
Next
Application.ScreenUpdating = True

End Sub
Sub Trans2()
Call Trans1
Dim ws As Worksheet, Sh As Worksheet
Dim C2 As Range
Set ws = Sheets("Names Data")
Set Sh = Sheets("الترحيل")
Application.ScreenUpdating = False
For Each C2 In Sh.Range("A10:A" & Sh.Range("A" & Rows.Count).End(xlUp).Row)
If C2.Value <> "" Then
C2.Offset(0, 1) = WorksheetFunction.VLookup(C2, ws.Range("A10:C1400"), 2, 0)
C2.Offset(0, 2) = WorksheetFunction.VLookup(C2, ws.Range("A10:C1400"), 3, 0)
End If
Next
Application.ScreenUpdating = True
End Sub

 

[Ali Mohamed Ali]

كود رائع وممتاز أستاذنا الكبير جعله الله فى ميزان حسناتك وبارك الله فيك

[نصر الإيمان]

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

هذا هو المطلوب - -  جعله الله في ميزان حسناتك

اشكرك على سعة صدرك لتساؤلاتي