كود نسخ صفحة من ملف اكسيل الى فولدر معين

[الفارس محمد رجب]

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

 

[omar elhosseini]

رمضان كريم

شاهد المرفق

Show _And_Copy_Sh.xls

[omar elhosseini]

عفوا

قم بتعديل هذا السطر

Wb_Name = "Test"
الي 

Wb_Name = ActiveSheet.Name
 

[lionheart]

In any worksheet module, put the following code

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
    Const sListBoxName As String = "Export Sheets"
    Dim ws As Worksheet, lst As ListBox, sPath As String, sFile As String, i As Long, c As Long
    If Target.Address = "$A$1" Then
        Cancel = True
        With Me
            Set lst = Nothing
            On Error Resume Next
                Set lst = .ListBoxes(sListBoxName)
            On Error GoTo 0
            If lst Is Nothing Then Set lst = .ListBoxes.Add(.Range("F2").Left, .Range("F2").Top, 160, 84)
        End With
        With lst
            .Name = sListBoxName
            .RemoveAllItems
            .MultiSelect = xlSimple
            For Each ws In ActiveWorkbook.Sheets
                .AddItem ws.Name
            Next ws
        End With
    ElseIf Target.Address = "$B$1" Then
        Cancel = True
        Set lst = Me.ListBoxes(sListBoxName)
        With lst
            For i = 1 To .ListCount
                If .Selected(i) Then
                    c = c + 1
                    sPath = ThisWorkbook.Path & "\"
                    With ActiveWorkbook.Sheets(.List(i))
                        Application.ScreenUpdating = False
                        Application.DisplayAlerts = False
                            .Copy: sFile = .Name
                            With Application.ActiveWorkbook
                                .SaveAs Filename:=sPath & sFile & ".xlsx"
                                .Close False
                            End With
                        Application.DisplayAlerts = True
                        Application.ScreenUpdating = True
                    End With
                End If
            Next i
        End With
        If c > 0 Then MsgBox "You Exported " & c & " Sheets Successfully", 64, "LionHeart"
    End If
End Sub

 

To use the code

Double-click cell A1 and a listbox with the worksheets names will be created

Select the sheet or sheets you want to export from the listbox

 Finally double-click cell B1 to export the sheets you selected from the listbox