VBA - 将 .xls 插入 .xlsm

Question

这篇文章是我之前post关于同一主题的一个更好的问题。

我正在尝试从 .xls 文件的第一张表中复制数据并将其粘贴到我的 .xlsm 文件中。如果 .xlsm 的“Sheet1”中没有数据，则将源数据粘贴到 .xlsm 的“Sheet1”中。但是，所有其他数据，都会创建一个新工作表并将其粘贴到该新创建的工作表中。

但是，目前，我的代码会打开 .xls 文件并停止。我尝试按照一些建议添加Stop，但这只是关闭了所有窗口。对于如何解决这个问题，我将不胜感激。如果我可以通过按一个按钮输入一个复制和粘贴命令，那就太好了。此代码将供客户使用，因此只需按一个按钮即可直观且易于使用。提前致谢。

Sub ImportData()

    Dim wkbCrntWorkBook As Workbook
    Dim wkbSourceBook   As Workbook
    Dim fNameAndPath As Variant

    Set wkbCrntWorkBook = ActiveWorkbook
    fNameAndPath = Application.GetOpenFilename(FileFilter:="Excel 2007, *.xls; *.xlsx; *.xlsm; *.xlsa", Title:="Select File To Import")
    If fNameAndPath = False Then Exit Sub
    Call ReadDataFromCloseFile(fNameAndPath)


    Set wkbCrntWorkBook = Nothing
    Set wkbSourceBook = Nothing

End Sub

Sub ReadDataFromCloseFile(filePath As Variant)
        Application.ScreenUpdating = False

        Dim src As Workbook

        Set src = Workbooks.Open(filePath, False, False)
        Stop
        Application.Visible = False

    ' COPY DATA FROM SOURCE (CLOSE WORKGROUP) TO THE DESTINATION WORKBOOK.
    ' GET THE TOTAL ROWS FROM THE SOURCE WORKBOOK.
    Dim srcRng As Range   ' last line from source
    Set srcRng = src.Worksheets("Sheet1").Range("A1",                         
    src.Worksheets("Sheet1").Range("A1")).End(xlDown)
    Set srcRng = srcRng.End(xlToRight)

    If Worksheets("Sheet1").Range("A1") = "" Then
        Worksheets("Sheet1").Range("A1") = srcRng
    Else:
        Worksheets.Add After:=(Sheets.Count)
        Worksheets("Sheet" & Sheets.Count).Range("A1") = srcRng
    End If


    ' CLOSE THE SOURCE FILE.
    src.Close False             ' FALSE - DON'T SAVE THE SOURCE FILE.
    Set src = Nothing

    Application.Visible = True
    Application.EnableEvents = True
    Application.ScreenUpdating = True
End Sub

Answer 1

我已经重构了ReadDataCloseFile() 过程。有几个语法问题（可以通过预先编译代码来解决），并且在理解运行时发生的事情方面也存在一些错误。

最值得注意的是，在检查范围 Worksheets("Sheet1") 的值时，如果您不符合特定工作簿的条件，代码将使用 ActiveWorkbook，在这种情况下将是 src，而不是您要检查的工作簿，我假设是带有代码的工作簿。

Option Explicit

Sub ReadDataFromCloseFile(filePath As Variant)

    Application.ScreenUpdating = False

    Dim src As Workbook
    Set src = Workbooks.Open(filePath, False, False)

    ' COPY DATA FROM SOURCE (CLOSE WORKGROUP) TO THE DESTINATION WORKBOOK.
    ' GET THE TOTAL ROWS FROM THE SOURCE WORKBOOK.
    Dim srcRng As Range   ' last line from source
    With src.Worksheets("Sheet1")
        Set srcRng = .Range(.Range("A1"), .Range("A1").End(xlDown).End(xlToRight))
    End With

    With ThisWorkbook
        If .Worksheets("Sheet1").Range("A1") = "" Then
            .Worksheets("Sheet1").Range("A1").Resize(srcRng.Rows.Count,srcRng.Columns.Count).Value = srcRng.Value
        Else:
            .Worksheets.Add After:=(.Sheets.Count)
            .Worksheets(.Sheets.Count).Range("A1").Resize(srcRng.Rows.Count,srcRng.Columns.Count).Value = srcRng.Value
        End If
    End With


    ' CLOSE THE SOURCE FILE.
    src.Close False             ' FALSE - DON'T SAVE THE SOURCE FILE.
    Set src = Nothing

End Sub

Answer 2

@ScottHoltzman 喝咖啡时 :) 试试这个...

更改调用以包含当前工作簿。

Call ReadDataFromCloseFile(fNameAndPath, wkbCrntWorkBook)

对于主要工作人员...

Sub AppendDataFromFile(filePath As Variant, targetBook As Workbook)
Dim src As Workbook
    On Error GoTo errHandler
    Application.ScreenUpdating = False
    Application.EnableEvents = False

    Set src = Workbooks.Open(filePath, False, False)

    ' COPY DATA FROM SOURCE (CLOSE WORKGROUP) TO THE DESTINATION WORKBOOK.
    ' GET THE TOTAL ROWS FROM THE SOURCE WORKBOOK.
    src.Worksheets(1).Cells.Copy
    With targetBook
        If IsSheetBlank(.Worksheets(1)) Then
            .Worksheets(1).Cells(1, 1).Paste
        Else
            Dim x As Worksheet
            .Worksheets.Add After:=.Sheets(.Sheets.Count)
            .Worksheets(.Sheets.Count).Paste
        End If
    End With
    ' CLOSE THE SOURCE FILE.
    src.Close False             ' FALSE - DON'T SAVE THE SOURCE FILE.
    Set src = Nothing

errHandler:
    If Err <> 0 Then
        MsgBox "Runtime Error: " & Err.Number & vbCr & Err.Description, , "AppendDataFromFile"
    End If
    Application.EnableEvents = True
    Application.ScreenUpdating = True
End Sub

辅助函数...

Function IsSheetBlank(Sheet As Worksheet) As Boolean
    IsSheetBlank = (WorksheetFunction.CountA(Sheet.Cells) = 0)
End Function