Excel VBA：從另一個工作簿複製行並粘貼到主工作簿

Question

我在一個文件夾（Test01，Test02，Test03）中有許多相同結構的excel文件。

我在同一個文件夾中創建另一個excel文件，需要從其他excel文件（結果）中提取信息。

每個測試文件中都有一個特定列需要複製並粘貼到結果文件的一行中。

我正在嘗試創建一個工具或宏，它可以通過按下一個按鈕，從每個文件中提取相同的列並將其粘貼到結果文件的新行中。

我無法更改測試文件中的任何內容，這應該在不打開每個文件的情況下自動完成。另外新的測試文件將被添加到文件夾（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 

這樣你就不必使用像激活報表時容易出錯在某些情況下。

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腳本運行」引用添加到您的項目（工具 - >引用，然後直到你看到庫向下滾動列表框，勾選複選框，在其左「，然後按」確定「）