How to copy sheets to another workbook using vba?

后端 未结 10 1843
故里飘歌
故里飘歌 2020-11-27 17:52

So, what I want to do, generally, is make a copy of a workbook. However, the source workbook is running my macros, and I want it to make an identical copy of itself, but wit

10条回答
  •  抹茶落季
    2020-11-27 18:02

    try this one

    Sub Get_Data_From_File()

         'Note: In the Regional Project that's coming up we learn how to import data from multiple Excel workbooks
        ' Also see BONUS sub procedure below (Bonus_Get_Data_From_File_InputBox()) that expands on this by inlcuding an input box
        Dim FileToOpen As Variant
        Dim OpenBook As Workbook
        Application.ScreenUpdating = False
        FileToOpen = Application.GetOpenFilename(Title:="Browse for your File & Import Range", FileFilter:="Excel Files (*.xls*),*xls*")
        If FileToOpen <> False Then
            Set OpenBook = Application.Workbooks.Open(FileToOpen)
             'copy data from A1 to E20 from first sheet
            OpenBook.Sheets(1).Range("A1:E20").Copy
            ThisWorkbook.Worksheets("SelectFile").Range("A10").PasteSpecial xlPasteValues
            OpenBook.Close False
            
        End If
        Application.ScreenUpdating = True
    End Sub
    

    or this one:

    Get_Data_From_File_InputBox()

    Dim FileToOpen As Variant
    Dim OpenBook As Workbook
    Dim ShName As String
    Dim Sh As Worksheet
    On Error GoTo Handle:
    
    FileToOpen = Application.GetOpenFilename(Title:="Browse for your File & Import Range", FileFilter:="Excel Files (*.xls*),*.xls*")
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    
    If FileToOpen <> False Then
        Set OpenBook = Application.Workbooks.Open(FileToOpen)
        ShName = Application.InputBox("Enter the sheet name to copy", "Enter the sheet name to copy")
        For Each Sh In OpenBook.Worksheets
            If UCase(Sh.Name) Like "*" & UCase(ShName) & "*" Then
                ShName = Sh.Name
            End If
        Next Sh
    
        'copy data from the specified sheet to this workbook - updae range as you see fit
        OpenBook.Sheets(ShName).Range("A1:CF1100").Copy
        ThisWorkbook.ActiveSheet.Range("A10").PasteSpecial xlPasteValues
        OpenBook.Close False
    End If
    Application.ScreenUpdating = True
    Application.DisplayAlerts = True
    Exit Sub
    

    Handle: If Err.Number = 9 Then MsgBox "The sheet name does not exist. Please check spelling" Else MsgBox "An error has occurred." End If OpenBook.Close False Application.ScreenUpdating = True Application.DisplayAlerts = True End Sub

    both work as

提交回复
热议问题