مطلوب بالكود_نقل كود و اسم الصنف من عدة اعمده لعمودين حسب المجموعه و بشرط

[جلال الجمال_ابو أدهم]

تحياتى و ايام مباركه

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

مرفق المثال

نقل كود و اسم الصنف من عدة اعمده لعمودين حسب المجموعه.rar

تم تعديل نوفمبر 13, 2016 بواسطه جلال الجمال_ابو أدهم

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

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

انسخ هذا الكود وخصص له زر

Sub Trans_Cod()
m = 3
Dim Arr As Variant, C As Range
Arr = Array("D", "F", "H", "J", "L", "N")
For i = LBound(Arr) To UBound(Arr)
Set C = Sheet1.Columns(Arr(i))
LR = Sheet1.Cells(Rows.Count, C.Column).End(xlUp).Row
For R = 5 To LR
If Not IsEmpty(Sheet1.Cells(R, C.Column)) Then
m = m + 1
Range("B" & m) = Sheet1.Cells(R, C.Column)
Range("A" & m) = Sheet1.Cells(R, C.Column).Offset(0, 1)
End If
Next
Next
End Sub

 

[جلال الجمال_ابو أدهم]

زيزو العجوز

تحياتى
جزاك الله خيرا و لكنه يقوم بالترحيل فى sheet1
ولكن يرجى الترحيل الى sheet2 بالعمودين A4_B4

شكرا

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

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

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

Sub Trans_Cod()
m = 3
Dim Arr As Variant, C As Range
LS = Sheet2.Range("A" & Rows.Count).End(xlUp).Row
Sheet2.Range("A4:B" & LS).ClearContents
Arr = Array("D", "F", "H", "J", "L", "N")
For i = LBound(Arr) To UBound(Arr)
Set C = Sheet1.Columns(Arr(i))
LR = Sheet1.Cells(Rows.Count, C.Column).End(xlUp).Row
For R = 5 To LR
If Not IsEmpty(Sheet1.Cells(R, C.Column)) Then
m = m + 1
With Sheet2
.Range("B" & m) = Sheet1.Cells(R, C.Column)
.Range("A" & m) = Sheet1.Cells(R, C.Column).Offset(0, 1)
End With
End If
Next
Next
End Sub

 

[جلال الجمال_ابو أدهم]

زيزو العجوز

تحياتى و جزاك الله خيرا
هو المطلوب

[جلال الجمال_ابو أدهم]

تحياتى و ايام مباركه
كان الكود يعمل و الان فيه مشكله
ماهو التعديل على الكود ليعمل كما هو مطلوب بالمرفق
و شكرا لحضرتك أ/ابراهيم الحداد 

نقل كود و اسم الصنف من عدة اعمده لعمود واحد حسب المجموعه.rar

تم تعديل نوفمبر 28, 2018 بواسطه جلال الجمال_ابو أدهم

[Ali Mohamed Ali]

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

[جلال الجمال_ابو أدهم]

تحياتى و ايام مباركه
تم تعديل الكود من زميل فاضل
و هو الان يعمل
 

Dim LR, LS, I, R, M As Integer
Dim Arr As Variant, C As Range
M = 3
LS = Sheet2.Range("A" & Rows.Count).End(xlUp).Row + 1
Sheet2.Range("A4:B" & LS).ClearContents
Arr = Array("D", "F", "H", "J", "L", "N")
    For I = LBound(Arr) To UBound(Arr)
        Set C = Sheet1.Columns(Arr(I))
        LR = Sheet1.Cells(Rows.Count, C.Column).End(xlUp).Row
        For R = 5 To LR
        If Not IsEmpty(Sheet1.Cells(R, C.Column)) Then
        M = M + 1
        With Sheet2
        .Range("B" & M) = Sheet1.Cells(R, C.Column)
        .Range("A" & M) = Sheet1.Cells(R, C.Column).Offset(0, 1)
        End With
        End If
        Next
    Next