循环遍历文件夹中的文件，post 内容到主文件中的空列，对于主文件新行中的每个源文件

Question

我是 VBA 的新手，我正在做一个文件夹中有多个 Excel 文件的项目，每个文件的结构都相同，我想遍历每个文件，在每个文件中搜索特定术语，复制它，然后以特定方式将其粘贴到主文件中。

除了以正确的方式粘贴外，我已经掌握了所有内容：

它在源文件中找到的每个术语都应该post编辑到主文件中的下一个空列，对于循环经过的每个新源文件，它应该post它找到的内容到主文件中的新行。

下面是我已经得到的。

Private Const sPath As String = "F:\ExamplePath"


Sub LoopThroughFiles()

Dim sFile As String 'File Name
Dim sExt As String 'File extension 
    
    sExt = "xlsx" 
    
    'loop through each file name and open it if the extension is correct
    sFile = Dir(sPath)
    Do Until sFile = ""
        If Right(sFile, 4) = sExt Then GetInfo sFile
        sFile = Dir
    Loop


End Sub

Private Sub GetInfo(sFile As String)

Dim wbFrom As Workbook 'workbook to copy the data from
Dim iRow As Integer 'row number of next empty row
Dim cl As Range
Dim strAddress As String

 On Error GoTo errHandle
 
    Application.EnableEvents = False
    Application.ScreenUpdating = False
 
    Set wbFrom = Workbooks.Open(sPath & sFile)
    
    
    
    'finds Search-Term
    With wbFrom.Sheets(1).Cells
    Set cl = .Find("necrosis_left", After:=.Range("C2"), LookIn:=xlValues)
        If Not cl Is Nothing Then
            strAddress = cl.Address
            cl.Select
            Selection.Copy
        iRow = Me.Range("A" & Rows.Count).End(xlUp).Row + 1 'Get an empty row in this workbook
        Me.Range("A" & iRow).PasteSpecial xlPasteAll 'past copied cells
        End If
     End With
        
        
    'finds other Search-Term
    With wbFrom.Sheets(1).Cells
    Set cl = .Find("necrosis_right", After:=.Range("C2"), LookIn:=xlValues)
        If Not cl Is Nothing Then
            strAddress = cl.Address
            cl.Select
            Selection.Copy
        iRow = Me.Range("A" & Rows.Count).End(xlUp).Row + 1 'Get an empty row in this workbook
        Me.Range("A" & iRow).PasteSpecial xlPasteAll 'past copied cells
        End If
     End With
       
   'many more search terms


    
       wbFrom.Close (False)
    Application.EnableEvents = True
    Application.ScreenUpdating = True
    Set wbFrom = Nothing
    
Exit Sub
errHandle:
MsgBox Err.Description
    Application.EnableEvents = True
    Application.ScreenUpdating = True
        
    
End Sub

所以我知道，我的问题出在这里：

iRow = Me.Range("A" & Rows.Count).End(xlUp).Row + 1 'Get an empty row in this workbook
Me.Range("A" & iRow).PasteSpecial xlPasteAll 'past copied cells

但我不太明白它是如何 post 变成一个空列而不是一个空行的，更不用说如何让它在主文件中为每个新的行向下一行源文件。

Answer 1

找到了我自己问题的答案！

第一步是将上面的“粘贴行”替换为以下内容：

Me.Cells(1, Columns.Count).End(xlToLeft).Offset(0, 1).PasteSpecial xlPasteAll

这会将每个复制的单元格粘贴到第 1 行中的下一个空列。

要为循环经过的每个源文件开始一个新行，必须声明一个 public 变量，它会在每次迭代中计算。最终代码如下所示：

Private Const sPath As String = 'enter your path
Public Zeile As Integer 'public variable


Sub LoopThroughFiles()

Dim sFile As String 'File Name
Dim sExt As String 'File extension you wish to open
    
    
   Zeile = 1 'important for not start pasting in row 0 (which is impossible)
    sExt = "xlsx" 'Change this if extension is different
    
    'loop through each file name and open it if the extension is correct
    sFile = Dir(sPath)
    Do Until sFile = ""
        If Right(sFile, 4) = sExt Then GetInfo sFile
        sFile = Dir
        Zeile = Zeile + 1 'goes up each iteration
    Loop


End Sub

Private Sub GetInfo(sFile As String)

Dim wbFrom As Workbook 'workbook to copy the data from
Dim iRow As Integer 'row number of next empty row
Dim cl As Range
Dim strAddress As String

 On Error GoTo errHandle
 
    Application.EnableEvents = False
    Application.ScreenUpdating = False
 
    Set wbFrom = Workbooks.Open(sPath & sFile)
    
   
     'copy the following block for each term you want to search for
    With wbFrom.Sheets(1).Cells
    Set cl = .Find("searchterm", After:=.Range("C2"), LookIn:=xlValues)
        If Not cl Is Nothing Then
            strAddress = cl.Address
            cl.Select
            Selection.Copy
       Me.Cells(Zeile, Columns.Count).End(xlToLeft).Offset(0, 1).PasteSpecial xlPasteAll 'the rows are controlled via the public variable 
        End If
     End With

      wbFrom.Close (False)
    Application.EnableEvents = True
    Application.ScreenUpdating = True
    Set wbFrom = Nothing
    
Exit Sub
errHandle:
MsgBox Err.Description
    Application.EnableEvents = True
    Application.ScreenUpdating = True
        
    
End Sub

结果遍历文件夹的所有文件，搜索特定术语并将每个结果粘贴到主文件的下一个空列中，但为每个源文件开始一个新行。

谢谢！

循环遍历文件夹中的文件，post 内容到主文件中的空列，对于主文件新行中的每个源文件

Loop through files in folder, post content to empty columns in master, for each source file in a new row of the master-file

excel

vba

loops

copy-paste