اذهب الي المحتوي
أوفيسنا
بحث مخصص من جوجل فى أوفيسنا
Custom Search

ترحيل مماثل


الردود الموصى بها

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

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

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

 

  • Like 1
رابط هذا التعليق
شارك

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

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

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

 

  • Like 1
رابط هذا التعليق
شارك

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

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

 

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

Untitled.png

تم تعديل بواسطه نصر الإيمان
رابط هذا التعليق
شارك

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

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

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

Untitled.png

تم تعديل بواسطه نصر الإيمان
رابط هذا التعليق
شارك

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

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

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

 

 

Untitled.png

تم تعديل بواسطه نصر الإيمان
رابط هذا التعليق
شارك

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

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

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

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

 

  • Like 1
رابط هذا التعليق
شارك

Join the conversation

You can post now and register later. If you have an account, sign in now to post with your account.

زائر
اضف رد علي هذا الموضوع....

×   Pasted as rich text.   Paste as plain text instead

  Only 75 emoji are allowed.

×   Your link has been automatically embedded.   Display as a link instead

×   Your previous content has been restored.   Clear editor

×   You cannot paste images directly. Upload or insert images from URL.

  • تصفح هذا الموضوع مؤخراً   0 اعضاء متواجدين الان

    • لايوجد اعضاء مسجلون يتصفحون هذه الصفحه
×
×
  • اضف...

Important Information