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

[omhamzh 17]

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

الاساتذة مشرفى المنتدى اتمنى المساعدة فى هذا الملف

لدى صفحة اسمها ترحيل اريد ترحيل المبالغ على اساس اسم الحساب المكتوب الى هو اسم شيت

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

وضعت نموذج مصغر من 3 شيتات وصفحة الترحيل وصفحة الجمع والضبط

مع امكانية زيادة عدد الصفحات ل15 او20 

بارك الله فيكم 

بارك الله فى من يقضى حوائج الناس 

ترحيل للحساب.xlsx

[سليم حاصبيا 7,558]

تغيير اسماء الصفحات الى الأجنبية لحسن عمل الكود و نسخه

Option Explicit
Dim i%, Lr%
Dim T As Worksheet
Dim Spes_sh As Worksheet
Dim Flter_rg As Range
'+++++++++++++++++++++++++++
Sub ADD_Sheets()
Set T = Sheets("Tarhil")
Lr = T.Cells(Rows.Count, 2).End(3).Row
If Lr < 2 Then Exit Sub
With T
    For i = 2 To Lr
        If Not Application.Evaluate("ISREF('" & _
         .Range("B" & i) & "'!A1)") Then
           Sheets.Add(, Sheets(Sheets.Count)).Name = _
         .Range("B" & i)
        End If
    Next
End With

End Sub
'+++++++++++++++++++++++++++
Sub transfer_data()
Application.ScreenUpdating = False
ADD_Sheets
 If Lr < 2 Then Exit Sub
 Set Flter_rg = T.Range("A1").CurrentRegion
For Each Spes_sh In Sheets
    If Spes_sh.Name = T.Name Or Spes_sh.Name = "Justify" Then
    Else
      Spes_sh.Range("A1").CurrentRegion.ClearContents
      Flter_rg.AutoFilter 2, Spes_sh.Name
      Flter_rg.SpecialCells(12).Copy
      Spes_sh.Range("A1").PasteSpecial (12)
    End If
Next

   If T.AutoFilterMode Then T.Range("A1").AutoFilter
   T.Select
   With Application
     .ScreenUpdating = True
     .CutCopyMode = False
   End With
End Sub

الملف مرفق

OM_HAMZA_SHEETS.xlsm

[omhamzh 17]

زادك الله من فضله الخلوق المساعد دائما لنا بارك الله فيك استاذ سليم

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

ونضغط للترحيل يمسح البيانات القديمة ايضا من الشيتات وهذا غير مطلوب

اعتذر اليك السماحة فى تعديله لاضافة الجديد الى الصفحات حتى لو مسحنا كل صفحة ترحيل وكتبنا بيانات جديدة للترحيل ترحل اسفل القديم

وده اول كود

ارجو منك اسماحة فى الكود الاخر لصفحةJustify ليقوم باستدعاء وتجميع البيانات بالتاريخ من الى تاريخ كما اوضحت بالصفحة بمعنى احتاج لكتابة التاريخ من فترة الى اخرى

واضغط استدعاء يستدعى البيانات واكن ممتنة لفضلك عليا سيدى الفاضل جعله الله بميزانك يوم يعرض العباد عليه ان شاء الله

[سليم حاصبيا 7,558]

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

البيانات المكررة في اي شيت يقوم الماكرو بادراحها مرة واحدة فقط 

بمعنى اخر لو تم الضغط على الزر اكثر من مرة (دون التعديل في البيانات Tarhil)   لا تتكرر البيانات 

Option Explicit
Dim i%, Max_ro%, K%, m%
Dim J As Worksheet
Dim Spes_sh As Worksheet
Dim D1 As Date, D2 As Date
'+++++++++++++++++++++++++++++++++++
Sub Fil_data()

Set J = Sheets("Justify")
J.Range("A5").CurrentRegion.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
m = 5
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, 1) = m - 4
                J.Cells(m, 2).Resize(, 11).Value = _
                Spes_sh.Cells(K, 1).Resize(, 11).Value
                m = m + 1
              End If
             Next K
      End If
Next_SHeeet:
Next Spes_sh
If m > 5 Then
  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
End If
End Sub

الملف من جديد

OM_HAMZA_SHEETS_NEW.xlsm

[omhamzh 17]

بارك الله فى حضرتك وحفظك ورعاك برعايته

الله يرضى عنك وعن ال بيتك اجمعين

كود الترحيل ممتاز اكثر الله خيرك وزاد رزقك اللهم امين

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

اعتذر لك

الان يستدعى مثلا sheeet ONE وتحته sheet ONE وتحته sheet ONE

اريد يستدعى SHEET ONE مرة واحدة متجمع الارقام فى الفترة ما بين التاريخين

الله يرضى عنك ويزيدك من فضله ويبارك لك فى علمك

ويدخل الجنة بحق مساعدتك لاخواتك ولقضائك حوائج الناس

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

[سليم حاصبيا 7,558]

وتجميع البيانات بالتاريخ من الى تاريخ 

كان يجب طلب هذا الشيء من البداية لا أضاعة لمزيد من الوقت 

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_HAMZA_WITH_SUMMATION.xlsm

[omhamzh 17]

اشكرك استاذ سليم ربنا يحفظك والله انا قولت والله العظيم والله

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

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

والله العظيم انا قولت والله

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

والله العظيم انا اسفة بالملف المطلوب وضعت الشكل المطلوب استدعائه وده اخر شئ والله العظيم اقسم بالله

ربنا يكرمك بين العباد اللهم امين

OM_HAMZA_WITH_SUMMATION.xlsm

[سليم حاصبيا 7,558]

وبرده على اساس اسم الشيت الى هو اسم الحساب

هذه لم افهمها

 

[omhamzh 17]

اعزك ورفع شأنك استاذ سليم هذا هو الشكل المطلوب استدعاء البيانات عليه

بارك الله فيك

الشيت المطلوب.xlsm

[سليم حاصبيا 7,558]

تم عمل المطلوب كما تريدين

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: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

الملف مرفق (الكود القديم ما زال يعمل اذا كانت هناك حاجة اليه)

Om_Hamz_Matloub.xlsm

[omhamzh 17]

الله اكبر عليك ماشاء الله تبارك الله ربنا يحفظك لاهلك ويطيل عمرك ويذهب عنك اى شر

ويهبك كل خير ويعزك بين العباد ويلبسك لباس الصحة دائما وابدا

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

كل الشكر