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

[هانى محمد]

السلام عليكم احبائى الكرام -ارجو التكرم على مساعدتى فى تعديل هذا الكود الذى يقوم

 بالترحيل من هذه الصفحة Main الى الصفحة الموجودة بالقائمة المنسدلة فى الخلية C1
على ان يتم بعد نهاية كل ترحيل  اضافة مثل هذا السطر الأصفر الموجود به كلمة Total على ان يأخذ هذه القيمة من الخلية H3 الى الورقة المرحل اليها

وللعلم هذا الكود من اعمال استاذنا الكبير سليم حاصبيا وسع الله فى رزقه وزاده الله من فضله Sub TransferToSpecificSheet2() Dim Cell As Range, t As String, LR As Long, LRT As Long Dim WS As Worksheet, Answer As Long, Bol As Boolean Set WS = Sheets("Main") LR = WS.Cells(1000, 3).End(xlUp).Row t = WS.Range("c1").Value Application.ScreenUpdating = False If Not IsEmpty(WS.Range("c1")) Then Bol = Evaluate("=ISREF(" & "'" & WS.Range("c1") & "'!A1)") If Not Bol Then Sheets.Add(, after:=Sheets(Sheets.Count)).Name = WS.Range("c1") WS.Range("A2:g" & LR).Copy With ActiveSheet .Range("a1").PasteSpecial (xlPasteValuesAndNumberFormats) .Range("a1").PasteSpecial (xlPasteColumnWidths) .Range("a1").PasteSpecial (xlPasteFormats) .DisplayRightToLeft = False End With WS.Select GoTo End_me End If WS.Range("A3:g" & LR).Copy With Sheets(t) LRT = .Cells(Rows.Count, 3).End(xlUp).Row + 1 With .Cells(LRT, 1) .PasteSpecial (xlPasteValuesAndNumberFormats) .PasteSpecial (xlPasteColumnWidths) .PasteSpecial (xlPasteFormats) End With End With Answer = MsgBox("Do you want to Clear the data on Sheet1 or not?", vbYesNo + vbQuestion) If Answer = vbYes Then Sheets("Main").Activate Sheets("Main").Range("b3:d1000,f3:f1000").Select Selection.ClearContents Else: End If Else End If End_me: Application.CutCopyMode = False Application.ScreenUpdating = True End Sub

Supplier.xlsm

[سليم حاصبيا]

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

Sub Transfer_with_total()
    Dim Cell As Range, t As String, LR As Long, LRT As Long
    Dim WS As Worksheet, Answer As Long, Bol As Boolean
    Dim Ro As Long
     Set WS = Sheets("Main")
    LR = WS.Cells(1000, 3).End(xlUp).Row
    t = WS.Range("c1").Value
        Application.ScreenUpdating = False
      If Not IsEmpty(WS.Range("c1")) Then
   
      Bol = Evaluate("=ISREF(" & "'" & WS.Range("c1") & "'!A1)")

  If Not Bol Then
    Sheets.Add(, after:=Sheets(Sheets.Count)).Name = WS.Range("c1")
    WS.Range("A2:g" & LR).Copy
      With ActiveSheet
      .Range("a1").PasteSpecial (xlPasteValuesAndNumberFormats)
      .Range("a1").PasteSpecial (xlPasteColumnWidths)
      .Range("a1").PasteSpecial (xlPasteFormats)
      .DisplayRightToLeft = False
      End With
      WS.Select
     GoTo End_me
  End If
                WS.Range("A3:g" & LR).Copy
                With Sheets(t)
                    LRT = .Cells(Rows.Count, 2).End(xlUp).Row + 1
                      With .Cells(LRT, 1)
                      .PasteSpecial (xlPasteValuesAndNumberFormats)
                      .PasteSpecial (xlPasteColumnWidths)
                      .PasteSpecial (xlPasteFormats)
                      End With
                      Ro = Application.CountA(.Range("c" & LRT).Resize(LR - 2))
                      .Cells(Ro + LRT, 2) = "Total"
                      .Cells(Ro + LRT, 2).Resize(, 3).HorizontalAlignment = 7
                      .Cells(Ro + LRT, 5) = WS.Range("h3")
                End With
     
    Answer = MsgBox("Do you want to Clear the data on Sheet1 or not?", vbYesNo + vbQuestion)
                If Answer = vbYes Then
                    Sheets("Main").Activate
                    Sheets("Main").Range("b3:d1000,f3:f1000").Select
                    Selection.ClearContents
                Else: End If
            Else
                    End If
End_me:
    Application.CutCopyMode = False
    Application.ScreenUpdating = True
End Sub

الملف مرفق

 

Supplier_new.xlsm

[هانى محمد]

والله لا يسمى هذا الا إبداع ... أحسنت استاذنا الكبير وهذا بالفعل هو المطلوب بارك الله فيك وزادك الله من فضله وأكرمك الله ووسع الله فى رزقك ورفعك الله اسمى الدرجات

كود ممتاز جعله الله فى ميزان حسناتك , اشكرك كثيرا واتمنى من الله تفريج كرباتك كما دائما تفرج كربات العباد