معرفة دفعات الموردين من حركة الصندوق والبنوك

[yasseru]

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

حركة الصندوق والبنوك.xlsx

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

جرب هذا الملف

Option Explicit
Sub get_data()
  Dim Inf As Worksheet
  Dim sh As Worksheet
  Dim OBJ As Object
  Dim S_rg As Range
  Dim first_row%, sec_row%, m%
  Dim max_ro%, Arr, ky
Set OBJ = CreateObject("Scripting.Dictionary")
Set Inf = Sheets("Info")
max_ro = Inf.Range("B2").CurrentRegion.Rows.Count
    If max_ro > 2 Then
        Inf.Range("B2").CurrentRegion. _
        Offset(2).Resize(max_ro - 2).Clear
    End If
 If Inf.Range("J1") = vbNullString Then Exit Sub
   
  For Each sh In Sheets
    If sh.Name <> Inf.Name Then
      Set S_rg = sh.Range("C:C").Find(Inf.Range("J1"), lookat:=1)
        If Not S_rg Is Nothing Then
         first_row = S_rg.Row: sec_row = first_row
            Do
              Arr = sh.Cells(sec_row, 3).Resize(, 6)
              Arr = Application.Transpose(Arr)
              Arr = Application.Transpose(Arr)
              
              OBJ(OBJ.Count) = Join(Arr, "*")
              Set S_rg = sh.Range("C:C").FindNext(S_rg)
              sec_row = S_rg.Row
             If sec_row = first_row Then Exit Do
            Loop
        End If 'find
    End If 'name
  Next 'sh
  m = 3
  If OBJ.Count Then
      For Each ky In OBJ.keys
        With Inf.Cells(m, 3)
          .Resize(, 6) = Split(OBJ(ky), "*")
          .Offset(, -1) = m - 2
         m = m + 1
       End With
       
      Next
   With Inf.Range("B3").Resize(m - 2, 7)
    .Value = .Value
    .Columns(5).Formula = "=SUM(D3,-E3)"
    .Borders.LineStyle = 1
    .InsertIndent 1
    .Font.Size = 14
    .Font.Bold = True
    .Interior.ColorIndex = 19
    .Value = .Value
   End With
 Inf.Cells(m, 2) = "المجموع"
   Inf.Cells(m, 4).Resize(, 3).Formula = _
    "=SUM(D3:D" & m - 1 & ")"
    Inf.Range("B" & m).Resize(, 7). _
    VerticalAlignment = 2
    
    Inf.Cells(m, 2).Resize(, 2). _
    HorizontalAlignment = 7
    
    Inf.Range("B" & m).Resize(, 7).Value = _
    Inf.Range("B" & m).Resize(, 7).Value
    Inf.Range("B" & m).Resize(, 7). _
    Interior.ColorIndex = 35
  Else
   MsgBox "This Name Not Exists"
  End If
End Sub

الملف مرفق

Sandook.xlsm

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

قليل من التنسيق الاصافي

بجيث يظهر لك مكان وجود الرصيد (اسم الشيت) مع تلوينه باللون الاصفر في الشيت 

Option Explicit
Sub get_data()
  Dim Inf As Worksheet
  Dim sh As Worksheet
  Dim OBJ As Object
  Dim OBJ_name As Object
  Dim S_rg As Range
  Dim first_row%, sec_row%, m%
  Dim max_ro%, Arr, ky
  Dim iNCLR As Range, iNCLR_RO%
Set OBJ = CreateObject("Scripting.Dictionary")
Set OBJ_name = CreateObject("Scripting.Dictionary")
Set Inf = Sheets("Info")
 '+++++++++++++++++++++++++++++
   For Each sh In Sheets
    If sh.Name <> Inf.Name Then
      Set iNCLR = sh.Range("B2").CurrentRegion
      iNCLR_RO = iNCLR.Rows.Count
      If iNCLR_RO > 2 Then
        iNCLR.Offset(2).Resize(iNCLR_RO - 2). _
        Interior.ColorIndex = xlNone
      End If
    End If
   Next
   '++++++++++++++++++++++++++++++++
max_ro = Inf.Range("B2").CurrentRegion.Rows.Count
    If max_ro > 2 Then
        Inf.Range("B2").CurrentRegion. _
        Offset(2).Resize(max_ro - 2).Clear
    End If
   
 If Inf.Range("J1") = vbNullString Then Exit Sub
   
  For Each sh In Sheets
    If sh.Name <> Inf.Name Then
      Set S_rg = sh.Range("C:C").Find(Inf.Range("J1"), lookat:=1)
        If Not S_rg Is Nothing Then
               first_row = S_rg.Row: sec_row = first_row
            Do
              sh.Cells(sec_row, 2).Resize(, 7) _
              .Interior.ColorIndex = 6
              Arr = sh.Cells(sec_row, 3).Resize(, 6)
              Arr = Application.Transpose(Arr)
              Arr = Application.Transpose(Arr)
              
              OBJ(OBJ.Count) = Join(Arr, "*")
              OBJ_name(OBJ_name.Count) = sh.Name
              Set S_rg = sh.Range("C:C").FindNext(S_rg)
              sec_row = S_rg.Row
             If sec_row = first_row Then Exit Do
            Loop
        End If 'find
    End If 'name
  Next 'sh
  m = 3
  If OBJ.Count Then
      For Each ky In OBJ.keys
        With Inf.Cells(m, 3)
          .Resize(, 6) = Split(OBJ(ky), "*")
          .Offset(, -1) = m - 2
          .Offset(, 6) = OBJ_name.Item(m - 3)
          m = m + 1
       End With
      
      Next
   With Inf.Range("B3").Resize(m - 2, 8)
    .Value = .Value
    .Columns(5).Formula = "=SUM(D3,-E3)"
    .Borders.LineStyle = 1
    .InsertIndent 1
    .Font.Size = 14
    .Font.Bold = True
    .Interior.ColorIndex = 19
    .Value = .Value
   End With
 Inf.Cells(m, 2) = "المجموع"
   Inf.Cells(m, 4).Resize(, 3).Formula = _
    "=SUM(D3:D" & m - 1 & ")"
    Inf.Range("B" & m).Resize(, 7). _
    VerticalAlignment = 2
    
    Inf.Cells(m, 2).Resize(, 2). _
    HorizontalAlignment = 7
    With Inf.Range("B" & m).Resize(, 8)
    .Value = .Value
    .Interior.ColorIndex = 35
    End With

  Else
   MsgBox "This Name Not Exists"
  End If
End Sub

الملف من جديد

Sandook_NEW.xlsm

[yasseru]

شكرا لحضرتك علي المجهود الرائع

[خيماوي كووول]

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

تفضل اخوي العزيز .. اختار الاسم ..

newworkbooks.xlsm

[خيماوي كووول]

تم اضافة المجموع ..

newworkbooks.xlsm

[yasseru]

برجاء المساعده في حالة البحث عن جزء من النص فقط لاظهار النتائج