yasseru قام بنشر ديسمبر 9, 2020 مشاركة قام بنشر ديسمبر 9, 2020 في شيت الاستعلام محتاج اعرف دفعات مورد معين من شيتات الصندوق والبنوك حركة الصندوق والبنوك.xlsx رابط هذا التعليق شارك More sharing options...
سليم حاصبيا قام بنشر ديسمبر 9, 2020 مشاركة قام بنشر ديسمبر 9, 2020 جرب هذا الملف 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 5 رابط هذا التعليق شارك More sharing options...
أفضل إجابة سليم حاصبيا قام بنشر ديسمبر 9, 2020 أفضل إجابة مشاركة قام بنشر ديسمبر 9, 2020 قليل من التنسيق الاصافي بجيث يظهر لك مكان وجود الرصيد (اسم الشيت) مع تلوينه باللون الاصفر في الشيت 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 4 رابط هذا التعليق شارك More sharing options...
yasseru قام بنشر ديسمبر 10, 2020 الكاتب مشاركة قام بنشر ديسمبر 10, 2020 شكرا لحضرتك علي المجهود الرائع رابط هذا التعليق شارك More sharing options...
خيماوي كووول قام بنشر ديسمبر 10, 2020 مشاركة قام بنشر ديسمبر 10, 2020 السلام عليكم ورحمة الله وبركاته تفضل اخوي العزيز .. اختار الاسم .. newworkbooks.xlsm 1 رابط هذا التعليق شارك More sharing options...
خيماوي كووول قام بنشر ديسمبر 10, 2020 مشاركة قام بنشر ديسمبر 10, 2020 تم اضافة المجموع .. newworkbooks.xlsm 2 رابط هذا التعليق شارك More sharing options...
yasseru قام بنشر يناير 11, 2021 الكاتب مشاركة قام بنشر يناير 11, 2021 برجاء المساعده في حالة البحث عن جزء من النص فقط لاظهار النتائج رابط هذا التعليق شارك More sharing options...
الردود الموصى بها
من فضلك سجل دخول لتتمكن من التعليق
ستتمكن من اضافه تعليقات بعد التسجيل
سجل دخولك الان