Jump to content
أوفيسنا

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


Recommended Posts

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

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

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

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

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

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

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

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

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

Link to post
Share on other sites

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

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

  • Like 1
  • Thanks 1
Link to post
Share on other sites

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

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

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

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

وده اول كود

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

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

Link to post
Share on other sites

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

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

بمعنى اخر لو تم الضغط على الزر اكثر من مرة (دون التعديل في البيانات 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

  • Like 4
Link to post
Share on other sites

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

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

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

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

اعتذر لك

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

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

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

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

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

Link to post
Share on other sites

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

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

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

  • Like 2
  • Thanks 1
Link to post
Share on other sites

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

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

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

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

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

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

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

OM_HAMZA_WITH_SUMMATION.xlsm

Link to post
Share on other sites

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

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

  • Like 4
Link to post
Share on other sites

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

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

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

كل الشكر

 

  • Like 1
Link to post
Share on other sites
Guest
This topic is now closed to further replies.
  • Recently Browsing   0 members

    No registered users viewing this page.

×
×
  • Create New...