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

Abo Judy · مارس 18, 2019

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

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

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

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

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

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

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

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

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

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

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

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

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

**سليم حاصبيا** · مارس 18, 2019

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

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

Abo Judy · مارس 18, 2019

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

جارى تحميل الملف و التجربة

تم تعديل مارس 18, 2019 بواسطه Abo Judy

Abo Judy · مارس 18, 2019

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

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

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

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

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

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

tartib _mars.xlsm

**سليم حاصبيا** · مارس 18, 2019

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

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

اختصرت البملف الى 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

Abo Judy · مارس 18, 2019

جزاك الله خير
جارى تحميل الملف و التجربة

**سليم حاصبيا** · مارس 18, 2019

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

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

Abo Judy · مارس 18, 2019

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

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

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

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

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

Abo Judy · مارس 19, 2019

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

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

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

**سليم حاصبيا** · مارس 20, 2019

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

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

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

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

Abo Judy · مارس 20, 2019

جزاك الله كل خير و غفر لك و لوالديك

ان شاءالله فى ميزان حسناتك

الحمدلله الملف شغال بدون ادنى مشكلة

تسجيل الدخول

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

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

Abo Judy

سليم حاصبيا

Abo Judy

Abo Judy

سليم حاصبيا

Abo Judy

سليم حاصبيا

Abo Judy

Abo Judy

سليم حاصبيا

Abo Judy

Join the conversation

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

تصفح الموقع

تصفح جديد الموقع

Support

Important Information