مساعدة في تعديل كود دمج بيانات ورقتين في ورقة

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

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

Sub consolidate()

Dim myInSht As Worksheet
Dim myOutSht As Worksheet
Dim aRow As Range
Dim aCol As Range
Dim myInCol As Range
Dim myOutCol As Range
Dim cell As Range
Dim iLoop As Long, jLoop As Long
jLoop = 2
' loop through the worksheets
For Each myInSht In ActiveWorkbook.Worksheets
' pick only the worksheets of interest
If myInSht.Name = "ورقة1" Or myInSht.Name = "ورقة2" Then
' find the columns of interest in the worksheet
For Each aCol In myInSht.UsedRange.Columns
Set myOutCol = Nothing
If aCol.Cells(1, 1).Value = "CODE" Then Set myOutCol = Sheets("ورقة3").Range("A:A")
If aCol.Cells(1, 1).Value = "BRAND" Then Set myOutCol = Sheets("ورقة3").Range("B:B")
If aCol.Cells(1, 1).Value = "QUANTITY" Then Set myOutCol = Sheets("ورقة3").Range("C:C")

If Not myOutCol Is Nothing Then
' don't move the top line, it contains the headers - no data
Set myInCol = aCol
Set myInCol = myInCol.Offset(1, 1).Resize(myInCol.Rows.Count - 1, myInCol.Columns.Count)
' transfer data from the project tab to the consolidated tab
iLoop = jLoop
For Each aRow In myInCol.Rows
myOutCol.Cells(iLoop, 1).Value = aRow.Cells(1, 1).Value
iLoop = iLoop + 1
Next aRow
End If
Next aCol
End If
If iLoop > jLoop Then jLoop = iLoop
Next myInSht
End Sub

 

دمج ورقتين بورقة.xlsm

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

لا حاجة لهذا الكم الكبير من Loop  يكفي هذا الماكرو

Option Explicit

Sub consolidate_new()
     Dim First As Worksheet, Second As Worksheet
     Dim F_Rg As Range, S_RG As Range
        
     Set First = Sheets("ورقة1")
     Set F_Rg = First.Range("A1").CurrentRegion
     Set Second = Sheets("ورقة2")
     Set S_RG = Second.Range("A1").CurrentRegion
    
     With Sheets("ورقة3")
        .Range("A1").CurrentRegion.Offset(1).ClearContents
         F_Rg.Offset(1).Resize(F_Rg.Rows.Count - 1).Copy .Cells(2, 1)
         S_RG.Offset(1).Resize(S_RG.Rows.Count - 1).Copy .Cells(F_Rg.Rows.Count + 1, 1)
     End With
 End Sub

 

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

شكرا  اخي سليم  على الكود  شغال تمام  ولكن عندي استفسار   لو تساعدني فيه   لو قمت بادراج TABLE جاهز   من الموجودة  في نافدة تصميم  الاكسيل  كيف يكون الكود الخاص بي  ListObjects("Table1")
اين يتم وضعه او التعديل في الكود