VBA-将.xls插入.xlsm

Question

这篇文章比我以前的文章中关于同一主题的问题更好。

我正在尝试从.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()过程。 存在两个语法问题（可以通过预先编译代码来解决），并且在理解运行时会发生什么方面也存在一些错误。

最值得注意的是，当检查range 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