从两个工作簿复制到两个工作表

Question

我有一个文件夹，用于存储两种类型的工作簿，它们是 [person_name]-RESUME.xlsx 和 [person_name].xlsx。使用我的代码，用户可以同时选择这两个文件。

我希望单击工作簿上的按钮，选择这两个文件，将 [person_name]-RESUME.xlsx 中的内容复制到 sheet1，将 [person_name].xlsx 中的内容复制到 sheet2，然后关闭这两个文件。

使用我的代码时出现错误Run-time error '91': Object variable or With block variable not set，当我单击“调试”时，它会在我的函数中突出显示ElseIf，我已经尝试打开单个文件的函数代码，它工作正常。下面是我的代码。

Sub opening_multiple_file()

    Dim i As Integer
    Dim myrange As Range
    Dim n_rows_A As Long, n_rows_B As Long, n_rows As Long
    'Opening File dialog box
    With Application.FileDialog(msoFileDialogFilePicker)
    
        'Enabling multiple files select
        .AllowMultiSelect = True
        .Filters.Clear
        
        'Only Excel files can be selected
        .Filters.Add "Excel Files", "*.xls*"
        
        If .Show = True Then
            For i = 1 To .SelectedItems.Count
                'Opening selected file
                Workbooks.Open .SelectedItems(i)
                
                'Check if file is a resume
                If InStr(.SelectedItems(i), "-RESUME") Then
                    
                    n_rows_A = CountRows(myrange)
                    n_rows_B = CountRows(myrange.Offset(0, 1))
                    n_rows = WorksheetFunction.Max(n_rows_A, n_rows_B)
                    
                    ' Do the copy here
                    Sheets("Sheet1").Range("A1").Resize(n_rows, 12).Value = _
                        myrange.Resize(n_rows, 12).Value
                    
                Else
                    
                    n_rows_A = CountRows(myrange)
                    n_rows_B = CountRows(myrange.Offset(0, 1))
                    n_rows = WorksheetFunction.Max(n_rows_A, n_rows_B)
                    
                    ' Do the copy here
                    Sheets("Sheet2").Range("A1").Resize(n_rows, 12).Value = _
                        myrange.Resize(n_rows, 12).Value
                    
                End If
            Next i
        End If
    End With
End Sub


Function CountRows(ByRef r As Range) As Long
    If IsEmpty(r) Then
        CountRows = 0
    ElseIf IsEmpty(r.Offset(1, 0)) Then
        CountRows = 1
    Else
        CountRows = r.Worksheet.Range(r, r.End(xlDown)).Rows.Count
    End If
End Function

我还想关闭新打开的工作簿。

Answer 1

从另一个工作簿复制范围

• 如果其他东西有效，您可以在 For Next 循环中使用类似以下的内容，包括它下面的函数。

片段

        Dim wb As Workbook
        Set wb = Workbooks.Open(.SelectedItems(i))
        myrange = getRange(wb.ActiveSheet, "A:B")
        
        If InStr(.SelectedItems(i), "-RESUME") Then
            ' Do the copy here
            ThisWorkbook("Sheet1").Range("A1") _
              .Resize(myrange.Rows.Count, 12).Value = _
              myrange.Resize(, 12).Value
        Else
            ' Do the copy here
            ThisWorkbook("Sheet2").Range("A1") _
              .Resize(myrange.Rows.Count, 12).Value = _
              myrange.Resize(, 12).Value
        End If
        wb.Close SaveChanges:=False

功能

Function getRange( _
    aWorksheet As Worksheet, _
    Optional ByVal ColumnAddress As String = "A", _
    Optional ByVal FirstRowNumber As Long = 1) _
As Range

    If Not aWorksheet Is Nothing Then
        With aWorksheet
            Dim rng As Range
            Set rng = .Columns(ColumnAddress) _
              .Resize(.Rows.Count - FirstRowNumber + 1) _
              .Offset(FirstRowNumber - 1)
            Dim cel As Range
            Set cel = rng.Find( _
              What:="*", _
              LookIn:=xlFormulas, _
              SearchOrder:=xlByRows, _
              SearchDirection:=xlPrevious)
            If Not cel Is Nothing Then
                Set getRange = rng.Resize(cel.Row - FirstRowNumber + 1)
            Else
            ' All cells below first row are empty.
            End If
        End With
    Else
    ' Worksheet not defined.
    End If

End Function