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

مطلوب تجميع الخلايا ذات الشرط if و تعديل كود الترحيل

Abo Judy

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

 مشاركة

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

Abo Judy

Abo Judy

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

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

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

بعد اذنكم عندى جدول لحركة الشاحنات عدد 10 شيت 

مطلوب تجميع ارقام الصف المسمى (سعر الطن) و انا حاولت و ما عرفت لان الصف يحتوى على اداة شرطية

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

 

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

المطلوب بعد اذنكم

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

ثانيا: ترحيل البيانات لحد آخر تاريخ تسجيل فى كل شيت

 ثالثاً : ايجاد الخطأ فى كود ترحيل البيانات الى الشيت الاخير و عدم تكرار اضافة الشيت الاخير مرة اخرى لانى بعمل تصفية للبيانات و ترقيم تلقائى

 

و جزاكم الله خير

مرفق الملف و به التوضيح المطلوب 

التريبات شهر مارس 2019.xlsm

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

سليم حاصبيا

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

جرب هذا الماكرو 

Sub Salim_filter()

'On Error Resume Next
 With Application
  .ScreenUpdating = False
  .Calculation = xlCalculationManual
  .EnableEvents = False
  End With

With Sheets("SALIM_BALANCE")
.Range("B2:H" & Rows.Count).ClearContents
.Range("k:k").Clear
End With

Dim x As Integer, LAST_ROW
Dim i As Byte, D%: D = 1
For i = 1 To Worksheets.Count
With Sheets(i)
  If .Name <> "SALIM_BALANCE" Then
    x = .Range("A" & Rows.Count).End(xlUp).Row
    .Range("b2:H" & x).Copy Sheets("SALIM_BALANCE").Range("B" & D + 1)
     With Sheets("SALIM_BALANCE")
    .Cells(D + 1, "K") = "BEGIN OF SHEET: " & .Name
    .Cells(D + 1, "K").Interior.ColorIndex = 35
     D = D + x + 1
    .Cells(D - 2, "K") = "END OF SHEET: " & .Name
    .Cells(D - 2, "K").Interior.ColorIndex = 44
    End With
  End If
End With
Next
With Application
  .ScreenUpdating = True
  .Calculation = xlCalculationAutomatic
  .EnableEvents = True
  End With
Sheets("SALIM_BALANCE").Select


End Sub

الملف مرفق

tartib _mars.xlsm

  • Thanks 1
رابط هذا التعليق
شارك
Abo Judy

Abo Judy

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

تمام يا استاذ سليم و جزاك الله خير

ملاحظة بسيطة : انا عايز الترحيل يكون للبيانات المتسجلة فقط و ليس باقى الصفحة الفارغ

بمعنى ترحيل البيانات ذات التاريخ فقط  و بدون فاصل بين كل شيت و آخر و باقى الصفحة الخالى من التاريخ لا يتم ترحيله

ثانيا ما هى طريقة تجميع خانات سعر الطن فى كل شيت لانها تحتوى على كود ولا اجد طريقة للتجميع

الملاحظات كتبتها فى الشيت الاخير و يوجد ملاحظة اخرى فى الشيت الاول (40104) فى آخر الصف

و اعتذر على الاطالة و جزاك الله خير

tartib _mars.xlsm

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

سليم حاصبيا

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

تم معالجة الامر

بالنسية للمعادلات في (سعر الطن)تم تصحيحها

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

يمكن نقل الكود الى الملف الصحيح و تصحيح المعادلات هناك 

Option Explicit

Sub Salim_filter1()

'On Error Resume Next
 With Application
  .ScreenUpdating = False
  .Calculation = xlCalculationManual
  .EnableEvents = False
  End With

With Sheets("SALIM_BALANCE")
.Range("A2:J" & Rows.Count).Clear
.Range("k:k").Clear
End With

Dim x As Integer, LAST_ROW
Dim i As Byte, D%: D = 1
Dim y%, k%: k = 1
Dim xx%

For i = 1 To Worksheets.Count
With Sheets(i)
  If .Name <> "SALIM_BALANCE" Then
    x = Application.Max(.Range("a:a")) + 1
    '==========================
    y = .Range("B:B").Find("*", after:=Cells(x, 2), LookIn:=xlFormulas).Row
        '================
    .Range("b2:J" & x).Copy Sheets("SALIM_BALANCE").Range("B" & D + 1)
    
     With Sheets("SALIM_BALANCE")
          With .Cells(D + 1, "K")
          .Value = "BEGIN OF SHEET: " & Sheets(i).Name
          .Interior.ColorIndex = 20
           D = D + x - 1
          End With
      .Cells(D, "K") = "END OF SHEET: " & Sheets(i).Name
      .Cells(D, "K").Interior.ColorIndex = 44
      
        With .Cells(D + 1, 1).Resize(, 10)
          .Value = Sheets(i).Cells(y, 1).Resize(, 10).Value
          .NumberFormat = "General"
          .Interior.ColorIndex = 35
        End With
      
      .Cells(D + 1, "K") = "SUM"
      D = D + 1
    End With
  End If
End With
Next
 With Sheets("SALIM_BALANCE")
  xx = .Cells(Rows.Count, "b").End(3).Row
   For i = 2 To xx
      If .Range("A" & i).Interior.ColorIndex <> 35 Then
        .Range("A" & i) = k
         k = k + 1
      Else
         k = 1
      End If
   Next
 End With
 
With Application
  .ScreenUpdating = True
  .Calculation = xlCalculationAutomatic
  .EnableEvents = True
  End With
Sheets("SALIM_BALANCE").Select


End Sub

الملف 

 

 

 

 

 

tartib _mars new.xlsm

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

سليم حاصبيا

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

تم التعديل اكثر وأكثر  ليبدو الامر أكثر وضوحاً 

Option Explicit

Sub Salim_filter1()


 With Application
  .ScreenUpdating = False
  .Calculation = xlCalculationManual
  .EnableEvents = False
  End With

With Sheets("SALIM_BALANCE")
.Range("A2:J" & Rows.Count).Clear
.Range("k:k").Clear
End With

Dim x%
Dim i As Byte, D%: D = 1
Dim y%, k%: k = 1
Dim xx%, m%
Dim t1%, t2%

For m = 1 To Worksheets.Count
With Sheets(m)
       If .Name <> "SALIM_BALANCE" Then
          x = Application.Max(.Range("a:a")) + 1
          y = .Range("B:B").Find("*", after:=Cells(x, 2), LookIn:=xlFormulas).Row
               Sheets("SALIM_BALANCE").Range("B" & D + 1).Resize(x - 1, 9).Value = _
              .Range("b2").Resize(x, 9).Value
                t1 = D + 1
            With Sheets("SALIM_BALANCE")
                      With .Cells(D + 1, "K")
                        .Value = "BEGIN OF SHEET: " & Sheets(m).Name
                        .Interior.ColorIndex = 20
                         D = D + x - 1
                         t2 = D
                      End With
                  .Cells(t2, "K") = "END OF SHEET: " & Sheets(m).Name
                  .Cells(t2, "K").Interior.ColorIndex = 44
                  .Cells(t2 + 1, "H").Formula = "=SUM(H" & t1 & ":H" & t2 & ")"
                  .Cells(t2 + 1, "J").Formula = "=SUM(J" & t1 & ":J" & t2 & ")"
                  .Cells(t2 + 1, 1).Resize(, 11).Interior.ColorIndex = 35
                  .Cells(t2 + 1, "K") = "SUMMATION Of SHEET " & Sheets(m).Name
                  D = D + 1
            End With
      End If
End With
Next
 With Sheets("SALIM_BALANCE")
      xx = .Cells(Rows.Count, "b").End(3).Row
          For i = 2 To xx
             If .Range("A" & i).Interior.ColorIndex <> 35 Then
               .Range("A" & i) = k
                k = k + 1
             Else
                k = 1
             End If
          Next
          
          With .Range("A2:K" & xx + 1)
            .Borders.LineStyle = xlContinuous
            .Font.Bold = True
            .InsertIndent 1
         End With
      .Range("B2:B" & xx).NumberFormat = "d/m/yyyy"
 End With
 
  With Application
  .ScreenUpdating = True
  .Calculation = xlCalculationAutomatic
  .EnableEvents = True
  End With
Sheets("SALIM_BALANCE").Select
End Sub

الملف الجديد

 

tartib _mars new_1.xlsm

  • Thanks 1
رابط هذا التعليق
شارك
Abo Judy

Abo Judy

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

اشكرك جدا جدا جدا يا استاذ سليم

و جزاك الله كل خير على الاهتمام و المساعدة

الكود تمام و الحمدلله تم المطلوب مع بعض التعديلات البسيطة

و الاهم هو طريقة حضرتك فى حل مشكلة تجميع ارقام الدالة if

مرة اخرى اشكرك و فى ميزان حسناتك ان شاءالله

  • Like 1
رابط هذا التعليق
شارك
Abo Judy

Abo Judy

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

السلام عليكم استاذ سليم

بعد نقل الكود للملف الاصلى ظهرت رسالة خطأ فى هذا السطر و الترقيم التلقائى اختفى

With Sheets("SALIM_BALANCE")
      xx = .Cells(Rows.Count, "b").End(3).Row
          For i = 2 To xx
             If .Range("A" & i).Interior.ColorIndex <> 35 Then
               .Range("A" & i) = k
                k = k + 1
             Else
                k = 1
             End If

 

 

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

With Sheets(m)
       If .Name <> "SALIM_BALANCE" Then
          x = Application.Max(.Range("a:a")) + 1
          y = .Range("B:B").Find("*", after:=Cells(x, 2), LookIn:=xlFormulas).Row
               Sheets("SALIM_BALANCE").Range("B" & D + 1).Resize(x - 1, 9).Value = _
              .Range("b2").Resize(x, 9).Value
                t1 = D + 1
            With Sheets("SALIM_BALANCE")

مرفق الملف

حساب التريبات شهر مارس 2019.xlsm

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

سليم حاصبيا

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

تم معالجة الامر

كانت هناك ورقة بيضاء بالملف تسببت بالخطأ

تم التعدبل على الكود ليغض النظر عن هذا الشيء   

Option Explicit

Sub Salim_New_filter()


 With Application
  .ScreenUpdating = False
  .Calculation = xlCalculationManual
  .EnableEvents = False
  End With

With Sheets("SALIM_BALANCE")
.Range("A2:J" & Rows.Count).Clear
.Range("k:k").Clear
End With

Dim x%
Dim i%, D%: D = 1
Dim y%, k%: k = 1
Dim xx%, m%
Dim t1%, t2%
Dim Saerch_Rg As Range

For m = 1 To Worksheets.Count
With Sheets(m)
       If .Name <> "SALIM_BALANCE" Then
          x = Application.Max(.Range("a:a")) + 1
          Set Saerch_Rg = .Range("B:B").Find("*", after:=Cells(x, 2), LookIn:=xlFormulas)
              If Not Saerch_Rg Is Nothing Then
               y = Saerch_Rg.Row
               Else: y = 0
               GoTo Next_m
              End If
              Sheets("SALIM_BALANCE").Range("B" & D + 1).Resize(x - 1, 9).Value = _
              .Range("b2").Resize(x, 9).Value
                t1 = D + 1
            With Sheets("SALIM_BALANCE")
                      With .Cells(D + 1, "K")
                        .Value = "BEGIN OF SHEET: " & Sheets(m).Name
                        .Interior.ColorIndex = 20
                         D = D + x - 1
                         t2 = D
                      End With
                  .Cells(t2, "K") = "END OF SHEET: " & Sheets(m).Name
                  .Cells(t2, "K").Interior.ColorIndex = 44
                  .Cells(t2 + 1, "H").Formula = "=SUM(H" & t1 & ":H" & t2 & ")"
                  .Cells(t2 + 1, "J").Formula = "=SUM(J" & t1 & ":J" & t2 & ")"
                  .Cells(t2 + 1, 1).Resize(, 11).Interior.ColorIndex = 35
                  .Cells(t2 + 1, "K") = "SUMMATION Of SHEET " & Sheets(m).Name
                  D = D + 1
            End With
      End If
End With
Next_m:

Next
 With Sheets("SALIM_BALANCE")
      xx = .Cells(Rows.Count, "b").End(3).Row
          For i = 2 To xx
             If .Range("A" & i).Interior.ColorIndex <> 35 Then
               .Range("A" & i) = k
                k = k + 1
             Else
                k = 1
             End If
          Next
          
          With .Range("A2:K" & xx + 1)
            .Borders.LineStyle = xlContinuous
            .Font.Bold = True
            .InsertIndent 1
         End With
      .Range("B2:B" & xx).NumberFormat = "d/m/yyyy"
 End With
 
  With Application
  .ScreenUpdating = True
  .Calculation = xlCalculationAutomatic
  .EnableEvents = True
  End With
Sheets("SALIM_BALANCE").Select
End Sub

 

Mars_Account_new.xlsm

  • Thanks 1
رابط هذا التعليق
شارك

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

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



سجل دخولك الان
 مشاركة
الذهاب الي قائمه المواضيع

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

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

Important Information

  I accept