VBA从多个文件中复制列，知道关键字。

Question

我是VBA新手，我想创建一个代码，从Sheet1中导出特定文件夹中的文件范围D10:D33，并将其粘贴到Sheet2中同一工作簿中的下一列中。

文件的名称根据日期的不同而改变，例如：YYYYMMDD_output。YYYYMMDD_output。文件夹里有很多日期，如20200609，20200610，我对20200608感兴趣。

下面的代码搜索关键字'20200608'找到文件，应该是把数据粘贴到Sheet2的Active工作簿中。我在循环更改名称文件时遇到了麻烦。

希望得到您的帮助。

 Option Explicit

 Sub copycolumns()

 Dim myPath As String
 Dim myFile As String
 Dim MyName As String
 Dim ws As Worksheet
 Dim wsl As Worksheet
 Dim r As Long

 myPath = "C:\Users\halo\Desktop\Backup"
 myFile = Dir(myPath & "20200608*.xlsx", vbNormal)

 Set ws = ActiveWorkbook.Worksheets("Sheet2")

 MyName = Dir(myPath & myFile)
 r = ws.Range("E" & Columns.Count).End(xlRight).Column + 1
 Do While MyName <> ""
    Workbooks.Open myPath & MyName
    Set ws1 = ActiveWorkbook.Worksheets("Sheet1")
    ws1.Range("D10:D33").Copy
    ws.Range(r, Columns.Count).End(xlToRight).Offset(0, 1).PasteSpecial xlValues

  Workbooks(MyName).Close SaveChanges:=False
  MyName = Dir

  Loop


 End Sub

Answer 1

请尝试下一个修改。

改变方式 r 计算中。

r = ws.Cells(1,  Columns.Count).End(xlToLeft).Column + 1

然后把线移到循环内

然后，将这一行转化为

ws.Range(r, Columns.Count).End(xlToRight).Offset(0, 1).PasteSpecial xlValues

在

ws.Cells(1, r).PasteSpecial xlValues

事实上，由于你只需要值（不是任何格式），所以最好使用数组。把你的(改编的)代码全部贴出来比较简单。请尝试下一个。

Sub copycolumns_Bis()

 Dim myPath As String
 Dim myFile As String
 Dim MyName As String
 Dim ws As Worksheet
 Dim wsl As Worksheet
 Dim r As Long

 myPath = "C:\Users\halo\Desktop\Backup"
 myFile = Dir(myPath & "20200608*.xlsx", vbNormal)

 Set ws = ActiveWorkbook.Worksheets("Sheet2")

 MyName = Dir(myPath & myFile)

 Do While MyName <> ""
    Dim arrCopy As Variant
    r = ws.Cells(1 & Columns.Count).End(xlToLeft).Column + 1
    Workbooks.Open myPath & MyName
    Set ws1 = ActiveWorkbook.Worksheets("Sheet1")
    arrCopy = ws1.Range("D10:D33").Value
    ws.Range(1, r).Resize(UBound(arrCopy, 1), UBound(arrCopy, 2)).Value = arrCopy
    Workbooks(MyName).Close SaveChanges:=False

    MyName = Dir
  Loop
 End Sub

如果有更多的列要复制，这段代码也可以用。我的意思是，要复制的范围可能包括更多的列。