تعديل لضبط تغير حجم الجدول طبقاً للنتائج

[samycalls2020]

السلام عليكم..

لدينا كود من ابداع الأخ الكريم / زيزو العجوز

وهو خاص بجلب بيانات من ملفين للثالث بناء على 3 معايير أو شروط

قمت بمحاولة فى الكود لإضافة خاصية لتغير حجم الجدول طبقاً للنتائج 

ولكن المحاولة غير موفقة .. كما هو بالمرفق .

الرجاء القيام بتعديل مايلزم فى الكود لضبط ما أضفته لهده الخاصية

وأيضاً أن يكون هناك سطر أخير بالجدول للمجاميع ..

 

تعديل لضبط تغير حجم الجدول طبقاً للنتائج.rar

[samycalls2020]

للرفع

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

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

جرب الكود بعد التعديل

ربما يكون هذا مقصدك

Sub ImportData1()
Application.ScreenUpdating = False
Dim wbBook1 As Workbook, wbBook2 As Workbook
Dim Path As String
Dim Arr As Variant, i As Long, x As Long, LR As Long, LS As Long
Dim a As String, b As String, d As String
Sheets("Get").Range("B7:J" & Sheets("Get").Range("E" & Rows.Count).End(xlUp).Row).ClearContents
Set wbBook1 = ThisWorkbook
Path = wbBook1.Path & "\"
Arr = Array("DATA1", "DATA2")
For x = LBound(Arr) To UBound(Arr)
Set wbBook2 = Workbooks.Open(Path & Arr(x) & ".xlsm")
Dim wsSheet1 As Worksheet
Dim wsSheet2 As Worksheet
Set wsSheet1 = wbBook1.Worksheets("Get")
a = wsSheet1.Range("E1").Value
b = wsSheet1.Range("E2").Value
d = wsSheet1.Range("E3").Value
Set wsSheet2 = wbBook2.Worksheets("Data")
LR = wsSheet2.Range("E" & Rows.Count).End(xlUp).Row
LS = wsSheet2.Cells(6, Columns.Count).End(xlToLeft).Column
For i = 3 To LR Step 1
If Trim(wsSheet2.Range("B" & i)) = Trim(a) And _
Trim(wsSheet2.Range("E" & i)) = Trim(d) And _
Trim(wsSheet2.Range("J" & i)) = Trim(b) Then
p = p + 1
wsSheet1.Range("C" & p + 6).Resize(, LS).Value = wsSheet2.Range("C" & i).Resize(p, LS).Value
wsSheet1.Range("B" & p + 6) = p
End If
Next
wbBook2.Close True
Next
Application.ScreenUpdating = True
End Sub

 

[samycalls2020]

الأخ الفاضل / زيزو .. شكراً على الاستجابه

كود ImportData الموجود فى المرفق تم اضافة 

 Dim tbl         As ListObject
    Dim shGet      As Worksheet

 

ثم

Set shGet = ThisWorkbook.Worksheets("Get")
    Set tbl = shGet.ListObjects("KATable")
    With tbl.DataBodyRange
    If .Rows.Count > 1 Then .Offset(1, 0).Resize(.Rows.Count - 1, .Columns.Count).Rows.Delete
    .Rows(0).ClearContents
   End With

لجعل الجدول يتغير فى عدد صفوفه طبقاُ للنتائج .. ولكن لم يعطينى النتيجة المرجوه منه

كما أتمنى أن يضاف فى نهائة الجدول سطر أخير  للمجاميع

[samycalls2020]

للرفع

[samycalls2020]

الحل اضافة تصفية للعمود 4 فى الجدول

فيكون كود ImportData1 كالتالى

Sub ImportData2()
Application.ScreenUpdating = False
Dim wbBook1 As Workbook, wbBook2 As Workbook
Dim Path As String
Dim Arr As Variant, i As Long, x As Long, LR As Long, LS As Long
Dim a As String, b As String, d As String
Sheets("Get").Range("KATable").ClearContents
Set wbBook1 = ThisWorkbook
Path = wbBook1.Path & "\"
Arr = Array("DATA1", "DATA2")
For x = LBound(Arr) To UBound(Arr)
Set wbBook2 = Workbooks.Open(Path & Arr(x) & ".xlsm")
Dim wsSheet1 As Worksheet
Dim wsSheet2 As Worksheet
Set wsSheet1 = wbBook1.Worksheets("Get")
a = wsSheet1.Range("E1").Value
b = wsSheet1.Range("E2").Value
d = wsSheet1.Range("E3").Value
Set wsSheet2 = wbBook2.Worksheets("Data")
LR = wsSheet2.Range("E" & Rows.Count).End(xlUp).Row
For i = 3 To LR Step 1
If Trim(wsSheet2.Range("B" & i)) = Trim(a) And _
Trim(wsSheet2.Range("E" & i)) = Trim(d) And _
Trim(wsSheet2.Range("J" & i)) = Trim(b) Then
p = p + 1
wsSheet1.Range("C" & p + 6 & ":J" & p + 6).Value = wsSheet2.Range("C" & i & ":J" & i).Value
wsSheet1.Range("B" & p + 6) = p
End If
Next
wbBook2.Close True
Next

  Sheets("Get").Range("KATable").AutoFilter Field:=4, Criteria1:= _
        "<>"
Application.ScreenUpdating = True
End Sub

 

[samycalls2020]

السلام عليكم

لقد قمت بعمل محاولة متواضعة 

لتعديل كود ImportData1 بتصفية للعمود رفم 4 لجدول KATable ..

فالأن يمكن أن يتغير حجم الجدول طبقاً للنتائج ويمكن اضافة صف للمجاميع ..

هذا الكود كما تعلم استاذى الفاضل / زيزو  خاص بجلب بيانات من ملفين للثالث بناء على 3 معايير أو شروط

فلا بد من وضع الثلاث شروط حتى يعمل الكود ويعطى النتيجة..

فهل يمكن أن تزيدنى من كرمك وفضلك .. بحث يمكن أن نكتفى بشرط واحد فيعطى الكود نتيجة ..  أو شرطين .. أو الثلاثة معاً

معذرة لأننى أثقلت عليك ..

[samycalls2020]

للرفع