أرجوا المساعدة في عمل قائمة منسدلة وعلاج بطء ملف الأكسيل

[حاتم عيسى]

بسم الله الرحمن الرحيم

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

مرفق الملف المطلوب العمل عليه

بارك الله في حضراتكم جميعا وجعل جميع أعمالكم في موازين حسناتكم ونفعكم الله بعلمكم وزاكم الله علمًا

برنامج الحسابات الجديد 05-01-2021 للتجميع3.xlsb

تم تعديل فبراير 2, 2021 بواسطه حاتم عيسى

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

سبب بطء البرنامج هو كثرة الألوان والتنسيفات

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

 

[حاتم عيسى]

الأستاذ : سليم حاصبيا

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

البطء الذي أقصده هو عند تنفيذ كود الترحيل إلى صفحات الحسابات فهل ذلك أيضا من التنسيقات والألوان أم أن هناك سبب أخر .

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

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

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

[حاتم عيسى]

الرجاء المساعدة في حل مشكلة بطء تنفيذ كود الترحيل إلى الحسابات

وكذلك المساعدة في وضع محتوى الخلية F3 في TextBox1 و وضع محتوى الخلية G3 في TextBox2

برنامج الحسابات الجديد 05-01-2021 للتجميع3.xlsb

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

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

الملف لا يفتح عندي بالشكل المطلوب

[حاتم عيسى]

باعتذر لحضرتك أستاذ : سليم على التأخير

كنت أقوم بإعداد ملف جديد وعمل المطلوب به كما طلبت حضرتك

وهو كما يلي

المطلوب من فضل حضراتكم

-         عمل تجميع للمبالغ المدينة والمبالغ الدائنة لكل عميل أو حساب .

-         عمل قائمة منسدلة في الخلية D3 تحتوى أسماء العملاء والحسابات الموجودة في العمود A بدون تكرار الأسماء ومؤبجدة وعند اختيار اسم من تلك يتم كتابتة في تلك الخلية D3 ويتم وضع إجمالي الرصيد المدين للعميل أو الحساب في الخلية f3 وإجمالي المبالغ الدائنة في الخلية g3.

-         عمل قائمة بأسماء الحسابات الموجودة في العمود A وتكون في العمود H .

-         ترحيل الحسابات إلى صفحات جديدة حسب اسم العميل أو الحساب الموجودة في العمود A مع جمع المبالغ المدينة والدائنة أسفل الفاتورة وإظهار الصافي مدين أو دائن كما هو موجود بصفحة الـ Print  .

-         عند كتابة اسم العميل في الخلية D3 يتم ترحيل جميع عملياته إلى صفحة Print مع جمع المبالغ المدينة والدائنة أسفل الفاتورة وإظهار الصافي مدين أو دائن كما هو موجود بصفحة الـ Print  .

 .الملف جديد للعمل عليه.xlsm

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

يا اخي او ان تشرح بالتفصيل ما تريد او أعتذر انا عن المساعدة

تساؤلات
1-عمل قائمة منسدلة في الخلية D3 تحتوى أسماء العملاء (في اي صفحة تريد ذلك؟؟؟؟)
2-     عمل قائمة بأسماء الحسابات الموجودة في العمود A وتكون في العمود H (في اي صفحة تريد ذلك؟؟؟؟)
3-الخلية F3 في TextBox1 و وضع محتوى الخلية G3 في TextBox2
      (لا أري اي    TextBox      أو    2TextBox  في الملف       )  
4- الملفي يجب ان يكون كما في المرفق ( و عندما يكتمل الملف لوّن ما تشاء و نسّق الالوان كما تريد)

5- كما ترى بعد ازالة النتسيقات انخفض حجم الملف من 255 كيلو الى  35 فقط )   حوالي 8 مرات

Issa_Hatem.xlsm

[حاتم عيسى]

تسلم يدك أستاذ سليم المحترم

1-عمل قائمة منسدلة في الخلية D3 تحتوى أسماء العملاء (في صفحة Data )
2-     عمل قائمة بأسماء الحسابات الموجودة في العمود A وتكون في العمود H (في صفحة Data)

وشكرا لحضرتك على المعلومات الرائعة هذه وكذلك أشكر حضرتك على سعة صدرك وتحملك لنا ولأسألتنا وطلباتنا .

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

جرب هذا الكود (لا تنس اضافة صف فارغ تماماً في كل صفحة الصف رقم 6 /مخفي لعدم الكتابة فيه عن طريق الخطأ)

Option Explicit

Sub taj()
    Dim P As Worksheet
    Dim D As Worksheet
    Dim m%, i%, Rod, Rop%
    Dim Obj As Object

Set D = Sheets("DATA")
Set P = Sheets("print")
Set Obj = CreateObject("System.Collections.ArrayList")

Rod = D.Cells(Rows.Count, 1).End(3).Row
Rop = P.Cells(Rows.Count, 1).End(3).Row
If Rod < 7 Then Exit Sub
D.Cells(7, "H").Resize(Rod).ClearContents
With Obj
    For i = 7 To Rod
       If Not .contains(D.Cells(i, 1).Value) And _
        D.Cells(i, 1) <> vbNullString Then
       .Add D.Cells(i, 1).Value
       End If
    Next i
    .Sort
        D.Cells(7, "H").Resize(.Count) = _
        Application.Transpose(.ToArray)

End With
      
With D.Cells(3, "D").Validation
  .Delete
  .Add 3, Formula1:=Join(Obj.ToArray, ",")

End With
  
  With P.Cells(3, "B").Validation
   .Delete
   .Add 3, Formula1:=Join(Obj.ToArray, ",")
  End With

Set Obj = Nothing

End Sub

الملف مرفق

Issa_Macro.xlsm

[حاتم عيسى]

الاستاذ الفاضل : سليم حاصبيا

تحية طيبة

بارك الله في حضرتك وجزاك الله خيرا .

هل من الممكن أن يتم عمل تلك القائمة اتوماتيك وليس بزر أمر

وكيف يتم عمل ترحيل الحسابات إلى صفحات جديدة باسم كل حساب أو عميل الموجود في صفحة Data في العمود A ويكون نهاية كل حساب في الصفحة يوجد مجموع المبالغ المدينة ومجموع المبالغ الدائنة وصافي العمليات .

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

هل من الممكن أن يتم عمل تلك القائمة اتوماتيك وليس بزر أمر  (تم عمل ذلك اذا لم تظهر ثائمة الاسماء غادر الصفحة ثم عد اليها)
1- عودة الصف رقم 6 للعمل داخل الصفحة(DATA) لضرورة انشاء جدول للفلتر

2-الضفحة تدرج مباشر ة بعد الشيت DATA

3- هذا الماكرو يدرج صفحة باسم كل عميل مع بياناته بشكل مستقل ( الزر Sheet For Every one)
4-اذا زاد عدد العملاء  الكود يتصرف بهذا الأمر

Option Explicit

Sub ADD_Sheet()
    Dim D As Worksheet
    Dim m%, i%, Rod, RoH%
    Dim Ft_rg As Range, Crit$
    Dim Ar_sh(), itm
Set D = Sheets("DATA")
Set Ft_rg = D.Range("a5").CurrentRegion
Rod = D.Cells(Rows.Count, 1).End(3).Row
RoH = D.Cells(Rows.Count, "H").End(3).Row
 
 With Application
  .ScreenUpdating = False
  .Calculation = xlCalculationManual
 End With

If Rod < 6 Or D.Cells(6, "H") = vbNullString Then
 GoTo Bay_Bay_Ya_Helween
End If
For i = RoH To 6 Step -1
        If Not Application.Evaluate("ISREF('" & _
         D.Range("H" & i) & "'!A1)") Then
           Sheets.Add(, after:=Sheets("DATA")).Name = _
         D.Range("H" & i)
        End If
 Next
 D.AutoFilterMode = 0
 
 For i = 1 To Sheets.Count
   If Sheets(i).Name = "print" Or Sheets(i).Name = "DATA" Then
   Else
    ReDim Preserve Ar_sh(m)
    Ar_sh(m) = Sheets(i).Name
    m = m + 1
   End If
  Next

 For Each itm In Ar_sh
 Sheets(itm).Range("A6").CurrentRegion.Clear
 Ft_rg.AutoFilter 1, itm
 Ft_rg.SpecialCells(12).Copy
 Sheets(itm).Range("A6").PasteSpecial (8)
  Sheets(itm).Range("A6").PasteSpecial
  Sheets(itm).Range("H6") = "Account Of" & Space(3) & itm _
  

 Next itm
 D.Select
 D.AutoFilterMode = 0
Bay_Bay_Ya_Helween:
 
 With Application
  .ScreenUpdating = True
  .Calculation = xlCalculationAutomatic
 End With

End Sub

 

Issa_Macro_New.xlsm

[حاتم عيسى]

استاذى الفاضل : سليم بك

ممكن من فضل وكرم اخلاق حضرتك

أن يتم الترحيل إلى صفحات العملاء كما توجد البيانات في صفحة Print على هذا التنسيق يعني مع وجود المجاميع أسفل كل صفحة مثل هذه الصورة

وعدم ترحيل العمود A ولا ترحيل الأعمدة F , G , H وشكرا لحضرتك وبارك الله في حضرتك فعلا عمل أكثر من ممتاز من أستاذ فاضل ومحترم

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

تم التعديل كما تريد

Sub fILTER_PLEASE()
    Dim D As Worksheet
    Dim m%, i%, Rod, RoH%
    Dim Ft_rg As Range
    Dim Ar_sh(), itm
     Dim Cret_range As Range
Set D = Sheets("DATA")
Set Ft_rg = D.Range("a5").CurrentRegion
Rod = D.Cells(Rows.Count, 1).End(3).Row
RoH = D.Cells(Rows.Count, "H").End(3).Row


 With Application
  .ScreenUpdating = False
  .Calculation = xlCalculationManual
 End With
    Application.DisplayAlerts = False
     For i = Sheets.Count To 1 Step -1
      If Sheets(i).Name = "print" Or Sheets(i).Name = "DATA" Then
      Else
       Sheets(i).Delete
      End If
     Next
    Application.DisplayAlerts = True
   taj
If Rod < 6 Or D.Cells(6, "H") = vbNullString Then
 GoTo Bay_Bay_Ya_Helween
End If
For i = RoH To 6 Step -1
        If Not Application.Evaluate("ISREF('" & _
         D.Range("H" & i) & "'!A1)") Then
           Sheets.Add(, after:=Sheets("DATA")).Name = _
         D.Range("H" & i)
        End If
 Next

 
 For i = 1 To Sheets.Count
   If Sheets(i).Name = "print" Or Sheets(i).Name = "DATA" Then
   Else
    ReDim Preserve Ar_sh(m)
    Ar_sh(m) = Sheets(i).Name
    m = m + 1
   End If
  Next

 For Each itm In Ar_sh
     With Sheets(itm)
             .Range("A:A").CurrentRegion.Clear
             .Range("C6") = D.Range("E5")
             .Range("D6") = D.Range("D5")
             .Range("E6") = D.Range("B5")
             .Range("F6") = D.Range("C5")
             .Range("B:B").EntireColumn.Hidden = True
                 With .Range("A6:F6")
                  .Font.Size = 16
                  .Font.Bold = True
                  .Borders.LineStyle = 1
                  .HorizontalAlignment = 3
                 End With
             .Range("A:A").ColumnWidth = 10
             .Range("C:C,E:E,F:F").ColumnWidth = 25
             .Range("D:D").ColumnWidth = 30
             .Range("H1") = D.Range("A5")
             .Range("H2") = .Name
             .Range("c2") = .Name
               
               With .Range("C2")
                .Font.Size = 18: .Font.Bold = True
                .Interior.ColorIndex = 6
                .Borders.LineStyle = 1
                .HorizontalAlignment = 3
               End With
               
             Set Cret_range = .Range("H1:h2")
  End With
             Ft_rg.AdvancedFilter 2, Cret_range, Sheets(itm).Range("C6:F6")
  With Sheets(itm)
              .Range("H1:H2").Clear
               m = .Cells(Rows.Count, 3).End(3).Row
            
               .Range("a7").Resize(m - 6) = _
               Evaluate("ROW(1:" & m - 6 & ")")
               .Range("d" & m + 1) = "SUM"
               .Range("e" & m + 1).Resize(, 2).Formula = _
               "=SUM(E7:E" & m & ")"
               .Range("D" & m + 1).Resize(, 3) _
               .Interior.ColorIndex = 24
               .Range("D" & m + 2) = "TOTAL"
               .Range("E" & m + 2) = _
               .Range("E" & m + 1) - .Range("F" & m + 1)
               .Range("D" & m + 2).Resize(, 2) _
                .Interior.ColorIndex = 35
               With .Range("A7").Resize(m - 4, 6).SpecialCells(12)
                 .Font.Size = 16
                 .Font.Bold = True
                 .Borders.LineStyle = 1
                 .InsertIndent 1
                 .Columns(1).HorizontalAlignment = 3
               End With
              
   End With
            Sheets(itm).Range("C6").CurrentRegion.Value = _
            Sheets(itm).Range("C6").CurrentRegion.Value
 Next itm
 D.Select
 If D.FilterMode Then D.ShowAllData

Bay_Bay_Ya_Helween:
 
 With Application
  .ScreenUpdating = True
  .Calculation = xlCalculationAutomatic
  .CutCopyMode = False
 End With

End Sub

 

 

 

Issa_New.xlsm

[حاتم عيسى]

الأستاذ الفاضل المحترم الخلوق : سليم حاصبيا

تحية طيبة ... وبعد

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

بقي الطلب الأخير هل ينفع عمل جمع للحسابات ( مدين ودائن ) أمام كل حسب أو عميل في صفحة الداتا Data في الأعمدة F . G

بارك الله في حضرتك وجزاك الله كل الخير

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

تفضل

Issa_New1.xlsm

[حاتم عيسى]

الأستاذ الفاضل المحترم الخلوق : سليم حاصبيا

تحية طيبة ... وبعد

فعلا أنا مش عارف أقول إيه لحضرتك على هذا المجهود الجبار الأكثر من رائع بارك الله في حضرتك وزادك الله من فضله ونفعك والأمة العربية جميعًا بعلمك وجعل الله جميع أعمالك في موازين حسنات حضرتك فهذا العمل أكثر مما كنت أحلم به وأتخيله .

بارك الله في حضرتك وجزاك الله كل الخير

شكرا شكرا شكرا شكرا شكرا شكرا شكرا