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

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


yasseru
إذهب إلى أفضل إجابة Solved by سليم حاصبيا,

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

جرب هذا الملف

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

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

  • أفضل إجابة

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

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

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

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

  • 1 month later...

من فضلك سجل دخول لتتمكن من التعليق

ستتمكن من اضافه تعليقات بعد التسجيل



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

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

Important Information