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

问题描述：

我在一个文件夹（Test01，Test02，Test03）中有许多相同结构的excel文件。Excel VBA：从另一个工作簿复制行并粘贴到主工作簿

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

每个测试文件中都有一个特定列需要复制并粘贴到结果文件的一行中。

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

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

VBA of Code and Test01 example

Results file

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

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功能不起作用，它不认识到它是一种功能。这就是我评论这些评论的原因。

工作表需要字符串值'工作表（”Sheet2“）。激活' – 2016-10-11 06:54:33

答

试着让一切明确

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

这样你就不必使用像激活报表时容易出错在某些情况下。

设置wbTarget = Workbooks.Open（”C：\ Users \ khanr1 \ Desktop \ Test_Excel \ Results.xlsm“ ）当我使用这一行时，它问我是否要重新打开该文件。如果我说是，它会重新打开，代码只是从开始到这一行循环。如果我说'不'，那么它会产生运行时错误。 – Ridwan

我的错误。您可以从Results.xlsm中运行代码。您不必打开此工作簿。我修改了代码。我已将其更改为'Set wbTarget = ThisWorkbook' – Barry

非常感谢Barry！现在你会碰巧知道如何在复制后将列转置为一行？ – Ridwan

答

看到不同的用途调用表：

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

工作簿（“结果。 XLSM “）。表（” 工作表Sheet “）。范围（” B2" ）。粘贴当我调试它时，这条线似乎不被识别。尝试下面的代码时遇到同样的问题。我认为“工作簿”没有得到承认。 – Ridwan

@Ridwan：看到编辑，它应该帮助你找到错误的有罪部分。当您启动代码时，您的工作簿“Results.xlsm”是否已经打开？ – R3uK

答

，因为你说“这应该是自动，而无需打开每个文件来完成。”，你可以试试这个：

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脚本运行”引用添加到您的项目（工具 - >引用，然后直到你看到库向下滚动列表框，勾选复选框，在其左“，然后按”确定“）

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

相关推荐