循环访问文件夹中的excel文件，提取列，并将它们粘贴到主文件中，其间有1个空列

我最近开始与VBA合作，并为自己分配了一个项目。

现在，这个macros应该循环遍历所有Excel文件的文件夹。 从它们中的每一个中提取一个范围，然后将它们粘贴在彼此旁边，并在主工作簿中间隔一个空列。

主手册

源工作簿1

我想添加另一个源工作簿，但我的声誉不允许这样做。

下面的代码是我在过去几周提出来的，但是我可以想象它可以更清晰。

现在，我无法在粘贴的列之间获得一个空列，并且出于某种原因，最后一个提取的列将被粘贴两次。

你能帮我解决这些问题吗？

Sub SelectDataTestLoop2() 'Dim file location and file name etc. Dim FilePath As Variant Dim FileName As Variant Dim WBcount As Integer Dim OtherWB As Workbook Dim ThisWB As Workbook Dim ThisWS As Worksheet Dim WS As Worksheet 'Sheet in which the data needs to be pasted (SignalCompilationFile) Set ThisWB = ActiveWorkbook Set ThisWS = ActiveSheet 'Define file location and file name FilePath = "C:\Users\907443\Desktop\VBA Test\FileTestMap\" FileName = Dir(FilePath & "*.xls?") WScount = 0 'Loop over all files in a folder, copy/paste data While FileName <> "" Set OtherWB = Workbooks.Open(FilePath & FileName) For Each WS In OtherWB.Worksheets Set CopyRange = OtherWB.Worksheets(4).Range("H2:H114") Set PasteRange = ThisWS.Cells(21, 14) CopyRange.Copy PasteRange.Offset(0, WScount).PasteSpecial xlPasteValues WScount = WScount + (1 / 7) Next WS FileName = Dir() Set OtherWB = Nothing Wend ThisWB.Activate ThisWS.Activate Set ThisWB = Nothing Set ThisWS = Nothing End Sub 

Answer 1

我已经评论你的代码，并希望它有帮助。

 Option Explicit Sub SelectDataTestLoop2() 'Dim file location and file name etc. Dim FilePath As String 'Variant Dim FileName As String 'Variant Dim WBcount As Integer Dim OtherWB As Workbook Dim ThisWB As Workbook Dim ThisWS As Worksheet Dim WS As Worksheet Dim CopyRange As Range ' declare all variables Dim TargetColumn As Long 'Sheet in which the data needs to be pasted (SignalCompilationFile) Set ThisWB = ActiveWorkbook ' logically, I expect ThisWorkbook Set ThisWS = ActiveSheet 'Define file location and file name FilePath = "C:\Users\907443\Desktop\VBA Test\FileTestMap\" FileName = Dir(FilePath & "*.xls?") ' WScount = 0 ' the Dim statement sets the value = 0 ' but there is no Dim statment for WScount ' use "Option Explicit" at the top of your code sheet TargetColumn = 2 ' define the frist column to paste to (2 = "B") 'Loop over all files in a folder, copy/paste data While FileName <> "" Set OtherWB = Workbooks.Open(FilePath & FileName) For Each WS In OtherWB.Worksheets Set CopyRange = OtherWB.Worksheets(4).Range("H2:H114") ' Set PasteRange = ThisWS.Cells(21, 14) ' this specifies N21 CopyRange.Copy ' PasteRange.Offset(0, WScount).PasteSpecial xlPasteValues ' paste to row 2 in Targetcolumn ThisWS.Cells(2, TargetColumn).PasteSpecial TargetColumn = TargetColumn + 2 ' WScount = WScount + (1 / 7) WBcount = WBcount + 1 Next WS FileName = Dir() OtherWB.Close SaveChanges:=False ' close the workbook after you are done with it ' Set OtherWB = Nothing Wend ' ThisWB.Activate ' after all OtherWb are closed ' this will be the ActiveWorkbook ' ThisWS.Activate ' - ditto - '' Set ThisWB = Nothing '' Set ThisWS = Nothing End Sub