المساعدة في عمل ميكرو للترحيل ونسخ الشيت

[سيد رجب]

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

المطلوب

1 ـ عمل ميكرو للتريل الاجماليات                   2 _ عمل ميكرو لنسخ الشيت للمشاريع بنفس التنسيق عدد 15 شيت وعليه زر الترحيل مفعل

 

 

 

الايرادات والمصروفات.xlsx

[الخطيب بيبوو]

يتم التوضيح  للمساعدة 

طلبك غير موضح  ماذا تريد

[سيد رجب]

اقصد تفعيل ميكرو ترحيل الاجمالي من شيت المسمي البون الي شيت كشف الحساب

و عمل ميكرو بشيت البون لنسخ نفس تنسيق الصفحة لعدد 15 بنفس التنسيق

[محمد هشام.]

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

جرب هدا 

Option Explicit
Sub Transfer()
    Dim srcRange As Range, Lr As Long, destCols As Variant
    Dim WS As Worksheet, dest As Worksheet, i As Integer
    Dim a(1 To 1, 1 To 7) As Variant
    
    Set WS = ActiveSheet
    Set dest = Sheets("كشف الحساب")

    a(1, 1) = WS.[B6].Value: a(1, 2) = WS.[C6].Value: a(1, 3) = WS.[D6].Value
    a(1, 4) = WS.[E6].Value: a(1, 5) = WS.[G6].Value: a(1, 6) = WS.[H6].Value: a(1, 7) = WS.[I6].Value

    destCols = Array("C", "D", "E", "F", "H", "I", "J")
    Lr = dest.Cells(dest.Rows.Count, "D").End(xlUp).Row + 1
    For i = 0 To 6
        dest.Cells(Lr, destCols(i)).Value = a(1, i + 1)
    Next i
End Sub

""""""""""""""""""""""""""""""""""""""""""""""""""""""""""

Sub testCopy()
    Dim i As Integer, ScrWS As Worksheet, btn As Object
    Dim Sh As Worksheet: Set Sh = Sheets("البون")

    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    Application.CutCopyMode = False

    For i = 1 To 15
        On Error Resume Next
        Set ScrWS = ThisWorkbook.Sheets(Sh.Name & i)
        If Not ScrWS Is Nothing Then ScrWS.Delete
    Next i
    For i = 1 To 15
        Sh.Copy After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count)
        Set ScrWS = ActiveSheet
        ScrWS.Name = Sh.Name & i
        ScrWS.DisplayRightToLeft = True
        For Each btn In ScrWS.Buttons: btn.Delete: Next btn
        On Error GoTo 0
        Set btn = ScrWS.Buttons.Add(400, 20, 60, 30): btn.OnAction = "Transfer": btn.Caption = "ترحيل"
    Next i
    Sh.Activate
    Application.ScreenUpdating = True
    Application.DisplayAlerts = True
End Sub

 

الايرادات والمصروفات.xlsm

[سيد رجب]

شكراً استاذي الفاضل هذا المطلوب

              ادم الله عليك من علمه وفضله 

                                       لكم جزيل الشكر