اذهب الي المحتوي
أوفيسنا

كود من تصميم الاستاذ سليم اريد زيادة عدد الاعمدة بكود الاستدعاء

omhamzh

بواسطه omhamzh
في منتدى الاكسيل Excel

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

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

omhamzh

omhamzh

قام بنشر
قام بنشر

السلام على من اتبع الهدى

الكود من تصميم استدى سليم حاصبيا واشكر فضله

حاولت بكل الطرق بس لم ينجح الكود والموضوع تم اغلاقه 

احتاج لشرج ما اقوم بعمله لزيادة الاعمدة للعمود P

بارك الله فى صاحب الكود الاستاذ سليم ونجاه من كل شر 

Option Explicit
Dim i%, Max_ro%, K%, m%, All_rows%
Dim J As Worksheet
Dim Spes_sh As Worksheet
Dim D1 As Date, D2 As Date
Dim x As Boolean

'+++++++++++++++++++++++++++++++++++
Sub Fil_data()
Dim t%, cont%, n%
m = 5: t = 5
Set J = Sheets("Justify")

All_rows = J.Cells(Rows.Count, 1).End(3).Row
If All_rows > 4 Then
J.Range("A5:L" & All_rows + 5).Clear
End If
If Not IsDate(J.Range("B2")) Or Not IsDate(J.Range("C2")) Then
 MsgBox "Type Please a reel date in B2 and C2"
 Exit Sub
End If
D1 = Application.Min(J.Range("B2"), J.Range("C2"))
D2 = Application.Max(J.Range("B2"), J.Range("C2"))
J.Range("B2") = D1: J.Range("C2") = D2

For Each Spes_sh In Sheets
       If Spes_sh.Name = "Tarhil" Or Spes_sh.Name = "Justify" Then
        Else
          Max_ro = Spes_sh.Cells(Rows.Count, 2).End(3).Row
              If Max_ro = 1 Then GoTo Next_SHeeet
             For K = 2 To Max_ro
               If Spes_sh.Cells(K, 1) <= D2 _
                And Spes_sh.Cells(K, 1) >= D1 Then
                J.Cells(m, 2).Resize(, 11).Value = _
                Spes_sh.Cells(K, 1).Resize(, 11).Value
                    If Not x Then
                      Else
                     J.Cells(m, 3) = ""
                    End If
                    x = True
                m = m + 1
              End If
             Next K
      End If
Next_SHeeet:
    If Spes_sh.Name = "Tarhil" Or _
      Spes_sh.Name = "Justify" Then
    Else
      J.Cells(m, 2) = "Sum"
      J.Cells(m, 4).Resize(, 9).Formula = _
      "=SUM(D" & t & ":D" & m - 1 & ")"
      m = m + 1
      t = m
   End If
x = False
  
Next Spes_sh
If m > 5 Then

 For cont = 5 To m - 1
        If J.Cells(cont, 2) <> "Sum" Then
        J.Cells(cont, 1) = n + 1
        n = n + 1
    Else
        J.Cells(cont, 1).Resize(, 12). _
        Interior.ColorIndex = 35
    End If
 Next cont
    
      With J.Cells(5, 1).Resize(m - 5, 12)
        .HorizontalAlignment = xlCenter
        .Borders.LineStyle = 1: .Font.Size = 14
        .Font.Bold = True
        .Value = .Value
        .InsertIndent 1
      End With
  
 For cont = 5 To m - 1
    If J.Cells(cont, 2) = "Sum" Then
      With J.Cells(cont, 2).Resize(, 2)
        .Merge
        .HorizontalAlignment = 3
      End With
    End If
 Next cont
  
End If
End Sub

والله ولى التوفيق

بارك الله فيك استاذ سليم 

تـــم تعديل الملف

Om_Hamz_Matloub.xlsm

رابط هذا التعليق
شارك
سليم حاصبيا

سليم حاصبيا

قام بنشر
قام بنشر

خلاص بفى احر مناقشة بهذا الموضوع

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

Option Explicit
Dim i%, Max_ro%, K%, m%, All_rows%
Dim J As Worksheet
Dim Spes_sh As Worksheet
Dim D1 As Date, D2 As Date
Dim x As Boolean

'+++++++++++++++++++++++++++++++++++
Sub Fil_data()
Application.ScreenUpdating = False
Dim t%, cont%, n%
m = 5: t = 5
Set J = Sheets("Justify")

All_rows = J.Cells(Rows.Count, 1).End(3).Row
If All_rows > 4 Then
J.Range("A5:O" & All_rows + 5).Clear
End If
If Not IsDate(J.Range("B2")) Or Not IsDate(J.Range("C2")) Then
 MsgBox "Type Please a reel date in B2 and C2"
 GoTo Buy_Buy_Ya_Helween
End If
D1 = Application.Min(J.Range("B2"), J.Range("C2"))
D2 = Application.Max(J.Range("B2"), J.Range("C2"))
J.Range("B2") = D1: J.Range("C2") = D2

For Each Spes_sh In Sheets
       If Spes_sh.Name = "Tarhil" Or Spes_sh.Name = "Justify" Then
        Else
          Max_ro = Spes_sh.Cells(Rows.Count, 2).End(3).Row
              If Max_ro = 1 Then GoTo Next_SHeeet
             For K = 2 To Max_ro
               If Spes_sh.Cells(K, 1) <= D2 _
                And Spes_sh.Cells(K, 1) >= D1 Then
                J.Cells(m, 2).Resize(, 14).Value = _
                Spes_sh.Cells(K, 3).Resize(, 14).Value
                    If Not x Then
                     J.Cells(m, 1) = Spes_sh.Name
                    End If
                    x = True
                m = m + 1
              End If
             Next K
      End If
      x = False
Next_SHeeet:
    If Spes_sh.Name = "Tarhil" Or _
      Spes_sh.Name = "Justify" Then
    Else
      J.Cells(m, 1) = "Sum"
      J.Cells(m, 2).Resize(, 14).Formula = _
      "=SUM(B" & t & ":B" & m - 1 & ")"
      m = m + 1
     t = m
   End If
x = False
  
Next Spes_sh
If m > 5 Then

 For cont = 5 To m - 1
    If J.Cells(cont, 1) = "Sum" Then
      J.Cells(cont, 1).Resize(, 15). _
      Interior.ColorIndex = 35
    End If
 Next cont
    J.Cells(m, 1) = "Sum Of ALL"
   
    J.Cells(m, 2).Resize(, 14).Formula = _
    "=SUM(B5:B" & m - 1 & ")/2"
    J.Cells(m, 1).Resize(, 15).Interior.ColorIndex = 40
      With J.Cells(5, 1).Resize(m - 4, 15)
        .HorizontalAlignment = xlCenter
        .Borders.LineStyle = 1: .Font.Size = 14
        .Font.Bold = True
        .Value = .Value
        .InsertIndent 1
      End With

End If
Buy_Buy_Ya_Helween:
Application.ScreenUpdating = True
End Sub

الملف مرفق

Om_Hamz_Super.xlsm

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

omhamzh

قام بنشر
  • الكاتب
قام بنشر

الله يرضى عنك وعن والديك بس الكود الثانى لم يتم فيه التعديل 

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

انا بشكرك زاد الله علمك وكرمك

الكود الاخر هو 


Application.ScreenUpdating = False
Set J = Sheets("Justify")

J.Range("A5:L5000").Clear

If Not IsDate(J.Range("B2")) Or Not IsDate(J.Range("C2")) Then
 MsgBox "Type Please a reel date in B2 and C2"
 Exit Sub
End If
D1 = Application.Min(J.Range("B2"), J.Range("C2"))
D2 = Application.Max(J.Range("B2"), J.Range("C2"))
J.Range("B2") = D1: J.Range("C2") = D2

For Each Spes_sh In Sheets
    If Spes_sh.Name = "Tarhil" Or Spes_sh.Name = "Justify" Then
    Else
        Max_ro = Spes_sh.Cells(Rows.Count, 2).End(3).Row
        Spes_sh.Range("A2").Resize(Max_ro - 1, 11) _
        .Interior.ColorIndex = 35
        For col = 3 To 11
            my_sum = 0
            For ro = 2 To Max_ro
                If Spes_sh.Cells(ro, 1) <= D2 And _
                  Spes_sh.Cells(ro, 1) >= D1 Then
                  Spes_sh.Cells(ro, 1).Interior.ColorIndex = 40
                  Spes_sh.Cells(ro, col).Interior.ColorIndex = 40
                  my_sum = my_sum + Val(Spes_sh.Cells(ro, col))
                End If
            Next ro
            
            ro = J.Cells(Rows.Count, "j").End(3).Row
            m = IIf(ro = 3, 5, ro + 1)
            J.Cells(m, col - 1) = my_sum
            J.Cells(m, 1) = Spes_sh.Name
        Next col
    End If

 Next Spes_sh
 If m > 5 Then
  J.Cells(m + 1, 1) = "SUM"
  J.Cells(m + 1, 2).Resize(, 9).Formula = _
    "=SUM(B5:B" & m & ")"
   J.Cells(5, "J").Resize(m - 4).Formula = _
    "=SUM(B5:I5)"
    With J.Cells(5, 1).Resize(m - 3, 10)
        .HorizontalAlignment = xlCenter
        .Borders.LineStyle = 1: .Font.Size = 14
        .Font.Bold = True
        .Value = .Value
        .InsertIndent 1
   End With
 J.Cells(m + 1, 1).Resize(, 10).Interior.ColorIndex = 40
End If
Application.ScreenUpdating = True
End Sub

 

  • Like 1
رابط هذا التعليق
شارك
سليم حاصبيا

سليم حاصبيا

قام بنشر
قام بنشر
الان, omhamzh said:

الله يرضى عنك وعن والديك بس الكود الثانى لم يتم فيه التعديل 

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

انا بشكرك زاد الله علمك وكرمك

الكود الاخر هو 



Application.ScreenUpdating = False
Set J = Sheets("Justify")

J.Range("A5:L5000").Clear

If Not IsDate(J.Range("B2")) Or Not IsDate(J.Range("C2")) Then
 MsgBox "Type Please a reel date in B2 and C2"
 Exit Sub
End If
D1 = Application.Min(J.Range("B2"), J.Range("C2"))
D2 = Application.Max(J.Range("B2"), J.Range("C2"))
J.Range("B2") = D1: J.Range("C2") = D2

For Each Spes_sh In Sheets
    If Spes_sh.Name = "Tarhil" Or Spes_sh.Name = "Justify" Then
    Else
        Max_ro = Spes_sh.Cells(Rows.Count, 2).End(3).Row
        Spes_sh.Range("A2").Resize(Max_ro - 1, 11) _
        .Interior.ColorIndex = 35
        For col = 3 To 11
            my_sum = 0
            For ro = 2 To Max_ro
                If Spes_sh.Cells(ro, 1) <= D2 And _
                  Spes_sh.Cells(ro, 1) >= D1 Then
                  Spes_sh.Cells(ro, 1).Interior.ColorIndex = 40
                  Spes_sh.Cells(ro, col).Interior.ColorIndex = 40
                  my_sum = my_sum + Val(Spes_sh.Cells(ro, col))
                End If
            Next ro
            
            ro = J.Cells(Rows.Count, "j").End(3).Row
            m = IIf(ro = 3, 5, ro + 1)
            J.Cells(m, col - 1) = my_sum
            J.Cells(m, 1) = Spes_sh.Name
        Next col
    End If

 Next Spes_sh
 If m > 5 Then
  J.Cells(m + 1, 1) = "SUM"
  J.Cells(m + 1, 2).Resize(, 9).Formula = _
    "=SUM(B5:B" & m & ")"
   J.Cells(5, "J").Resize(m - 4).Formula = _
    "=SUM(B5:I5)"
    With J.Cells(5, 1).Resize(m - 3, 10)
        .HorizontalAlignment = xlCenter
        .Borders.LineStyle = 1: .Font.Size = 14
        .Font.Bold = True
        .Value = .Value
        .InsertIndent 1
   End With
 J.Cells(m + 1, 1).Resize(, 10).Interior.ColorIndex = 40
End If
Application.ScreenUpdating = True
End Sub

 

انت طلبت التعديل على هذا الماكرو فقط

  • Sad 1
رابط هذا التعليق
شارك
  • أفضل إجابة
سليم حاصبيا

سليم حاصبيا

قام بنشر
  • أفضل إجابة
قام بنشر

الكود الثّاني 

Option Explicit

Dim i%, Max_ro%, m%
Dim J As Worksheet
Dim ro%, col%, my_sum#
Dim Spes_sh As Worksheet
Dim D1 As Date, D2 As Date
'+++++++++++++++++++++++++++++++++++
Sub Fil_data_All()
Application.ScreenUpdating = False
Set J = Sheets("Justify")

J.Range("A5:O5000").Clear

If Not IsDate(J.Range("B2")) Or Not IsDate(J.Range("C2")) Then
 MsgBox "Type Please a reel date in B2 and C2"
 GoTo Live_Me_PLease
End If
D1 = Application.Min(J.Range("B2"), J.Range("C2"))
D2 = Application.Max(J.Range("B2"), J.Range("C2"))
J.Range("B2") = D1: J.Range("C2") = D2

For Each Spes_sh In Sheets
    If Spes_sh.Name = "Tarhil" Or Spes_sh.Name = "Justify" Then
    Else
   
        Max_ro = Spes_sh.Cells(Rows.Count, 2).End(3).Row
        Spes_sh.Range("A2").Resize(Max_ro - 1, 16) _
        .Interior.ColorIndex = 35
        For col = 3 To 16
            my_sum = 0
            For ro = 2 To Max_ro
                If Spes_sh.Cells(ro, 1) <= D2 And _
                  Spes_sh.Cells(ro, 1) >= D1 Then
                  Spes_sh.Cells(ro, 1).Interior.ColorIndex = 40
                  Spes_sh.Cells(ro, col).Interior.ColorIndex = 40
                  my_sum = my_sum + Val(Spes_sh.Cells(ro, col))
                End If
            Next ro
            
            ro = J.Cells(Rows.Count, "O").End(3).Row
            m = IIf(ro <= 3, 5, ro + 1)
            J.Cells(m, col - 1) = my_sum
            J.Cells(m, 1) = Spes_sh.Name
        Next col
    End If

 Next Spes_sh
 If m > 5 Then
  J.Cells(m + 1, 1) = "SUM"
  J.Cells(m + 1, 2).Resize(, 14).Formula = _
    "=SUM(B5:B" & m & ")"
   J.Cells(5, "O").Resize(m - 4).Formula = _
    "=SUM(B5:N5)"
    With J.Cells(5, 1).Resize(m - 3, 15)
        .HorizontalAlignment = xlCenter
        .Borders.LineStyle = 1: .Font.Size = 14
        .Font.Bold = True
        .Value = .Value
        .InsertIndent 1
   End With
 J.Cells(m + 1, 1).Resize(, 15).Interior.ColorIndex = 40
End If
Live_Me_PLease:
Application.ScreenUpdating = True
End Sub

 

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

omhamzh

قام بنشر
  • الكاتب
قام بنشر

شكرا ليك يا اطيب انسان

اربنا يحفظك ويزيدك من فضله ويعزك ويرفع شأنك ويديم عليك كل نعمه

اختك فى الله تقدم لك كل الشكر موقف شهم جداااااااااا من حضرتك ربنا يعزك ويحفظك

  • Like 1
رابط هذا التعليق
شارك
زائر
هذا الموضوع مغلق.
 مشاركة
الذهاب الي قائمه المواضيع

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

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

Important Information

  I accept