Question

我能够利用其他代码从外部工作簿导入工作表，但是代码要求我手动更改工作表名称。

我目前在工作簿A中有一个列，其中包含我试图从工作簿B（其中包含数百个工作表）中提取的每个（大约20个）工作表的名称。有没有办法循环此代码并引用工作簿A中的列来更改我的宏中的工作表名称从工作簿B中提取？下面的代码（假设WORKSHEET1是我从工作簿B中提取的工作表的名称）

Sub ImportSheet() 
Dim sImportFile As String, sFile As String 
Dim sThisBk As Workbook 
Dim vfilename As Variant 
Application.ScreenUpdating = False 
Application.DisplayAlerts = False 
Set sThisBk = ActiveWorkbook 
sImportFile = Application.GetOpenFilename( _ 
FileFilter:="Microsoft Excel Workbooks, *.xls; *.xlsx", Title:="Open Workbook") 
If sImportFile = "False" Then 
    MsgBox "No File Selected!" 
    Exit Sub 

Else 
    vfilename = Split(sImportFile, "\") 
    sFile = vfilename(UBound(vfilename)) 
    Application.Workbooks.Open Filename:=sImportFile 

    Set wbBk = Workbooks(sFile) 
    With wbBk 
        If SheetExists("WORKSHEET1") Then 
            Set wsSht = .Sheets("WORKSHEET1") 
            wsSht.Copy before:=sThisBk.Sheets("Sheet1") 
        Else 
            MsgBox "There is no sheet with name :WORKSHEET1 in:" & vbCr & .Name 
        End If 
        wbBk.Close SaveChanges:=False 
    End With 
End If 
Application.ScreenUpdating = True 
Application.DisplayAlerts = True 
End Sub 
Private Function SheetExists(sWSName As String) As Boolean 
Dim ws As Worksheet 
On Error Resume Next 
Set ws = Worksheets(sWSName) 
If Not ws Is Nothing Then SheetExists = True

结束功能

Answer 1

已修改请尝试以下操作。

Sub ImportSheet()
    Dim sImportFile As String, sFile As String
    Dim wbThisWB As Workbook
    Dim wbTheOtherWB As Workbook
    Dim vfilename As Variant
    Dim WSName As String
    Dim LastRow As Long

    Application.ScreenUpdating = False
    Application.DisplayAlerts = False

    Set wbThisWB = ThisWorkbook
    LastRow = wbThisWB.Worksheets("Sheet1").Cells(Rows.Count, 1).End(xlUp).Row 'get the last row whith sheets names

    sImportFile = Application.GetOpenFilename( _
    FileFilter:="Microsoft Excel Workbooks, *.xls; *.xlsx", Title:="Open Workbook")

    If sImportFile = "False" Then
        MsgBox "No File Selected!"
        Exit Sub

    Else
        vfilename = Split(sImportFile, "\")
        sFile = vfilename(UBound(vfilename))
        Application.Workbooks.Open Filename:=sImportFile

        Set wbTheOtherWB = Workbooks(sFile)

        With wbTheOtherWB
            For i = 1 To LastRow 'rows in current workbook with worksheets names
                WSName = wbThisWB.Worksheets("Sheet1").Cells(i, 1) 'where you place sheets names (here column A, from row 1 down)
                If sheetExists(WSName, wbTheOtherWB) Then
                    Set wsSht = .Sheets(WSName)
                    wsSht.Copy before:=wbThisWB.Sheets("Sheet1")
                Else
                    MsgBox "There is no sheet with name : " & WSName & " in:" & vbCr & .Name
                End If
            Next
            wbTheOtherWB.Close SaveChanges:=False
        End With
    End If
    Application.ScreenUpdating = True
    Application.DisplayAlerts = True
End Sub

Function sheetExists(sheetToFind As String, wbTheOtherWB As Workbook) As Boolean
    sheetExists = False
    For Each Sheet In wbTheOtherWB.Worksheets
        If sheetToFind = Sheet.Name Then
            sheetExists = True
            Exit Function
        End If
    Next Sheet
End Function

Excel VBA-从外部工作簿将特定工作表导入工作簿

1 个答案: