Excel VBA：从另一个工作簿复制行并粘贴到主工作簿

Question

我在一个文件夹（Test01，Test02，Test03）中有许多相同结构的excel文件。

我在同一文件夹中创建了另一个excel文件，需要从其他excel文件中提取信息（结果）。

每个Test文件中都有一个特定的列，我需要将其复制并粘贴到Results文件的一行中。

我正在尝试创建一个工具或宏，只需按一下按钮，就可以从每个文件中提取相同的列并将其粘贴到Results文件中的新行中。

我无法改变测试文件中的任何内容，这应该在不打开每个文件的情况下自动完成。 此外，新的测试文件将添加到文件夹（Test04，Test05等）中，因此该功能应该能够从新文件中提取。

我的代码不运行，而是收到运行时错误：

Private Sub CommandButton1_Click()

'Dim info

'info = isWorkBookopen("C:\Users\Ridwan\Desktop\Test_Excel\Test01.xlsm")
'If info = False Then
Workbooks.Open Filename:="C:\Users\Ridwan\Desktop\Test_Excel\Test01.xlsm"
'End If

Worksheets(Sheet2).Activate  'This is giving me a runtime error

Range("C2:C10").Copy

'Need functions to paste into Results.xlsm

End Sub

另外，我的isWorkBookopen函数不起作用，它不能将其识别为函数。 这就是我评论这些界限的原因。

Answer 1

尽量使一切都明确

Private Sub CommandButton1_Click()

Dim wbSource as Workbook
Dim wbTarget as Workbook    
Dim shSource as Worksheet
Dim shTarget as Worksheet

' Open workbook to copy from as readonly
Set wbSource = Workbooks.Open(Filename:="C:\Users\Ridwan\Desktop\Test_Excel\Test01.xlsm", ReadOnly:=true)

' The data is copies to this workbook
Set wbTarget = ThisWorkbook    

' Did you enclose the worksheet name with double quotes?
' Reference to sheet to copy from
set shSource = wbSource.Worksheets("Sheet2")

' Reference to sheet to copy to
set shTarget = wbTarget.Worksheets("Sheet to copy to")

' Copy data to first column in target sheet
shSource.Range("C2:C10").Copy Destination:= shTarget.Cells(1,1)

End Sub

这样您就不必使用像Activate这样的语句，这些语句在某些情况下容易出错。

Answer 2

查看呼叫表的不同用途：

Private Sub CommandButton1_Click()

Dim wB As Workbook
Dim wS As Worksheet

Set wB = Workbooks.Open(Filename:="C:\Users\Ridwan\Desktop\Test_Excel\Test01.xlsm")


Set wS = wB.Sheets("SheetName") 'Name of the sheet in Excel
''OR
'Set wS = wB.Sheet2 'Name that you'll see in VBE in parenthesis

wS.Range("C2:C10").Copy

Dim wB2 As Workbook
Dim wS2 As Worksheet
Dim rG As Range

'if Results.xlsm as already open
Set wB2 = Workbooks("Results.xlsm")
Set wS2 = wB2.Sheets("Sheet1")
Set rG = wS2.Range("B2")
rG.Paste

End Sub

Answer 3

因为你说“这应该在不打开每个文件的情况下自动完成。” ，你可以试试这个：

Option Explicit

Sub main()
    Dim fso As New FileSystemObject
    Dim testFolder As Folder
    Dim f As File
    Dim i As Long

    Set testFolder = fso.GetFolder("C:\Users\Ridwan\Desktop\Test_Excel")
    With Worksheets("Results")
        For Each f In testFolder.Files
            If Left(f.Name, 4) = "Test" Then
                If fso.GetExtensionName(f.Path) = "xlsm" Then
                    With .Cells(.Rows.Count, 1).End(xlUp).Offset(1)
                        .Value = f.Name
                        i = 0
                        Do
                            i = i + 1
                            .Offset(, i).Formula = "='" & testFolder.Path & "\[" & f.Name & "]Sheet1'!C" & i + 1
                        Loop While .Offset(, i) <> 0
                        .Offset(, i).ClearContents
                        With Range(.Offset(, 1), .Offset(, 1).End(xlToRight))
                            .Value = .Value
                        End With
                    End With
                End If
            End If
        Next f
    End With
End Sub

它需要将“Microsoft Scripting Runtime”引用添加到您的项目中（工具 - >引用，然后向下滚动列表框，直到您看到该库，勾选其左侧的复选框并按“确定”）