VBA数组套用数组进行文件夹下的文件夹下的文件抽取数据到另一个excel

于 2023-09-12 18:15:32 发布
阅读量513 收藏
点赞数
分类专栏： VBA excel 文件夹套用 文章标签： 开发语言 bash excel 编辑器
版权声明：本文为博主原创文章，遵循 CC 4.0 BY-SA 版权协议，转载请附上原文出处链接和本声明。
本文链接：https://blog.csdn.net/2301_77630091/article/details/132269420
版权
博客分享了关于文件夹写入数组的代码，包括三个版本，有带文件夹提示和不带提示的。作者提醒定义数组 StrFileDir() 时后面不要接类型，否则会报类型不匹配问题，还欢迎大家分享更好的方法。

摘要生成于 C知道 ，由 DeepSeek-R1 满血版支持， 前往体验 >

正文

打开office，启用宏，就能进行各种看起来很有逼格的操作，就比如说此篇文章主题<文件夹写入数组>

不多说直接代码

代码：

第三版：（无文件夹提示）

Sub ExtractDataFromSpecifiedFilesWithCondition()
    Dim SourcePath As String
    Dim OutputPath As String
    Dim OutputWorkbook As Workbook
    Dim SourceFile As String
    Dim SourceFilea As String
    Dim SourceWorkbook As Workbook
    Dim SourceSheet As Worksheet
    Dim LastRow As Long
    Dim NextRow As Long
    Dim SourceCell As Range 'ⅰ僢儔儌儂僩僔V儈qqqqqqqqqqq
    Dim asd As String
    
    ' 设置源文件夹路径和目标文件?81D_1A_幵椉埶懚幚憰_峔憿愝寁彂_儗價儏乕巜揈帠崁qw
    SourcePath = ChooseFolder() & "\"
    OutputPath = "D:\11\11.xlsx"
    
    ' 打开或创建目标Excel文件
    On Error Resume Next
    Set OutputWorkbook = Workbooks.Open(OutputPath)
    On Error GoTo 0
    
    If OutputWorkbook Is Nothing Then
        Set OutputWorkbook = Workbooks.Add
    End If
    
    ' 设置目标工作表
敾暿巇敾暿巇條彂斾妑_儗價儏乕qwC:\Users\heyulong\Desktop\崙暿巇條愗懼僔乕儖 -v006.xlsm
    Set OutputSheet = OutputWorkbook.Sheets.Add(After:=OutputWorkbook.Sheets(OutputWorkbook.Sheets.count))
    OutputSheet.Name = "MergedData"
    
    ' 循环处理源文件夹中的每个Excel文件
    SourceFile = Dir(SourcePath & "*巜揈帠崁.xlsx")
    
    Do While SourceFile <> ""
        ' 打开源Excel文件
        Set SourceWorkbook = Workbooks.Open(SourcePath & SourceFile)
        
        ' 循环处理源工作簿中的每个工作表


        For Each SourceSheet In SourceWorkbook.Sheets
            LastRow = SourceSheet.Cells(SourceSheet.Rows.count, "C").End(xlUp).Row
            
            ' 检查每一行的A列，如果包含"指摘"则复制数据
            For Each SourceCell In SourceSheet.Range("C1:C" & LastRow)
                If InStr(1, SourceCell.Value, "xlsx", vbTextCompare) > 0 Then
                    NextRow = OutputSheet.Cells(OutputSheet.Rows.count, "C").End(xlUp).Row + 1
                    SourceSheet.Range("C" & SourceCell.Row).Resize(1, SourceSheet.UsedRange.Columns.count).Copy _
                        Destination:=OutputSheet.Cells(NextRow, 1)
                End If
            Next SourceCell
       Next SourceSheet
        
        ' 关闭源Excel文件
        SourceWorkbook.Close SaveChanges:=False
        
        ' 查找下一个源文件
        SourceFile = Dir
        Loop
        
   '1
    Dim StrFileDira()
    Dim Dica, Patha, MyNamea, Fsoa, Fsa, Fca, Fa, Na, StrPatha

    Patha = SourcePath

    Set Fsoa = CreateObject("Scripting.FileSystemobject")
    Set Fsa = Fsoa.GetFolder(Patha)
    Set Fca = Fsa.SubFolders

    For Each Fa In Fca
      StrPatha = Patha & Fa.Name
       Na = Na + 1
       ReDim Preserve StrFileDira(Na)
       StrFileDira(Na) = StrPatha
    Next

   ' For a = 1 To UBound(StrFileDira)
   '  MsgBox StrFileDira(a)
   ' Next
    '2
      Dim StrFileDir()
      
    Dim Dic, Path, MyName, Fso, Fs, Fc, F, N, StrPath

       For e = 1 To Na
       
     
    Path = StrFileDira(e) & "\"

    Set Fso = CreateObject("Scripting.FileSystemobject")
    Set Fs = Fso.GetFolder(Path)
    Set Fc = Fs.SubFolders
    For Each F In Fc
      StrPath = Path & F.Name
       N = N + 1
       ReDim Preserve StrFileDir(N)
       StrFileDir(N) = StrPath
    Next
    Next

      'For i = 1 To UBound(StrFileDir)
    '  MsgBox StrFileDir(i)
     ' Next
    '3
     For i = 1 To N
     asd = StrFileDir(i) & "\"
     SourceFilea = Dir(asd & "*巜揈帠崁.xlsx")
    Do While SourceFilea <> ""
  ' If SourceFile <> "." And SourceFile <> ".." Then
    ' 打开源Excel文件
    Set SourceWorkbook = Workbooks.Open(asd & SourceFilea)
    ' 循环处理源工作簿中的每个工作表 
    For Each SourceSheet In SourceWorkbook.Sheets
    LastRow = SourceSheet.Cells(SourceSheet.Rows.count, "C").End(xlUp).Row
    ' 检查每一行的A列，如果包含"指摘"则复制数据
    For Each SourceCell In SourceSheet.Range("C1:C" & LastRow)
    If InStr(1, SourceCell.Value, "xlsx", vbTextCompare) > 0 Then
    NextRow = OutputSheet.Cells(OutputSheet.Rows.count, "C").End(xlUp).Row + 1
    SourceSheet.Range("A" & SourceCell.Row).Resize(1, SourceSheet.UsedRange.Columns.count).Copy _
    Destination:=OutputSheet.Cells(NextRow, 1)
    End If
    Next SourceCell
    Next SourceSheet
    ' 关闭源Excel文件
    SourceWorkbook.Close SaveChanges:=False
    ' 查找下一个源文件
    SourceFilea = Dir
    Loop
    Next
     
    
    ' 关闭并保存目标Excel文件
    OutputWorkbook.SaveAs OutputPath
    OutputWorkbook.Close SaveChanges:=False
    
    MsgBox "数据已提取并保存到" & OutputPath
End Sub
'选择文件夹
Function ChooseFolder() As String
    Dim dlgOpen     As FileDialog

    Set dlgOpen = Application.FileDialog(msoFileDialogFolderPicker)
    With dlgOpen
        If .Show = -1 Then
            ChooseFolder = .SelectedItems(1)
        End If
    End With
    Set dlgOpen = Nothing
End Function

第二版数组循环套用：（有文件夹提示）

Sub ExtractDataFromSpecifiedFilesWithCondition()
    Dim SourcePath As String
    Dim OutputPath As String
    Dim OutputWorkbook As Workbook
    Dim SourceFile As String
    Dim SourceFilea As String
    Dim SourceWorkbook As Workbook
    Dim SourceSheet As Worksheet
    Dim LastRow As Long
    Dim NextRow As Long
    Dim SourceCell As Range 'ⅰ僢儔儌儂僩僔V儈qqqqqqqqqqq
    Dim asd As String
    
    ' 设置源文件夹路径和目标文件?81D_1A_幵椉埶懚幚憰_峔憿愝寁彂_儗價儏乕巜揈帠崁qw
    SourcePath = ChooseFolder() & "\"
    OutputPath = "D:\11\11.xlsx"
    
    ' 打开或创建目标Excel文件
    On Error Resume Next
    Set OutputWorkbook = Workbooks.Open(OutputPath)
    On Error GoTo 0
    
    If OutputWorkbook Is Nothing Then
        Set OutputWorkbook = Workbooks.Add
    End If
    
    ' 设置目标工作表
敾暿巇敾暿巇條彂斾妑_儗價儏乕qwC:\Users\heyulong\Desktop\崙暿巇條愗懼僔乕儖 -v006.xlsm
    Set OutputSheet = OutputWorkbook.Sheets.Add(After:=OutputWorkbook.Sheets(OutputWorkbook.Sheets.count))
    OutputSheet.Name = "MergedData"
    
    ' 循环处理源文件夹中的每个Excel文件
    SourceFile = Dir(SourcePath & "*巜揈帠崁.xlsx")
    
    Do While SourceFile <> ""
        ' 打开源Excel文件
        Set SourceWorkbook = Workbooks.Open(SourcePath & SourceFile)
        
        ' 循环处理源工作簿中的每个工作表


        For Each SourceSheet In SourceWorkbook.Sheets
            LastRow = SourceSheet.Cells(SourceSheet.Rows.count, "C").End(xlUp).Row
            
            ' 检查每一行的A列，如果包含"指摘"则复制数据
            For Each SourceCell In SourceSheet.Range("C1:C" & LastRow)
                If InStr(1, SourceCell.Value, "xlsx", vbTextCompare) > 0 Then
                    NextRow = OutputSheet.Cells(OutputSheet.Rows.count, "C").End(xlUp).Row + 1
                    SourceSheet.Range("C" & SourceCell.Row).Resize(1, SourceSheet.UsedRange.Columns.count).Copy _
                        Destination:=OutputSheet.Cells(NextRow, 1)
                End If
            Next SourceCell
       Next SourceSheet
        
        ' 关闭源Excel文件
        SourceWorkbook.Close SaveChanges:=False
        
        ' 查找下一个源文件
        SourceFile = Dir
        Loop
        
   '1
    Dim StrFileDira()
    Dim Dica, Patha, MyNamea, Fsoa, Fsa, Fca, Fa, Na, StrPatha

    Patha = SourcePath

    Set Fsoa = CreateObject("Scripting.FileSystemobject")
    Set Fsa = Fsoa.GetFolder(Patha)
    Set Fca = Fsa.SubFolders

    For Each Fa In Fca
      StrPatha = Patha & Fa.Name
       Na = Na + 1
       ReDim Preserve StrFileDira(Na)
       StrFileDira(Na) = StrPatha
    Next

    For a = 1 To UBound(StrFileDira)
     MsgBox StrFileDira(a)
    Next
    '2
      Dim StrFileDir()
    Dim Dic, Path, MyName, Fso, Fs, Fc, F, N, StrPath

       For e = 1 To Na
       
     
    Path = StrFileDira(e) & "\"

    Set Fso = CreateObject("Scripting.FileSystemobject")
    Set Fs = Fso.GetFolder(Path)
    Set Fc = Fs.SubFolders
    For Each F In Fc
      StrPath = Path & F.Name
       N = N + 1
       ReDim Preserve StrFileDir(N)
       StrFileDir(N) = StrPath
    Next
    Next

      For i = 1 To UBound(StrFileDir)
      MsgBox StrFileDir(i)
      Next
    '3
     For i = 1 To N
     asd = StrFileDir(i) & "\"
     SourceFilea = Dir(asd & "*巜揈帠崁.xlsx")
    Do While SourceFilea <> ""
  ' If SourceFile <> "." And SourceFile <> ".." Then
    ' 打开源Excel文件
    Set SourceWorkbook = Workbooks.Open(asd & SourceFilea)
    ' 循环处理源工作簿中的每个工作表 
    For Each SourceSheet In SourceWorkbook.Sheets
    LastRow = SourceSheet.Cells(SourceSheet.Rows.count, "C").End(xlUp).Row
    ' 检查每一行的A列，如果包含"指摘"则复制数据
    For Each SourceCell In SourceSheet.Range("C1:C" & LastRow)
    If InStr(1, SourceCell.Value, "xlsx", vbTextCompare) > 0 Then
    NextRow = OutputSheet.Cells(OutputSheet.Rows.count, "C").End(xlUp).Row + 1
    SourceSheet.Range("A" & SourceCell.Row).Resize(1, SourceSheet.UsedRange.Columns.count).Copy _
    Destination:=OutputSheet.Cells(NextRow, 1)
    End If
    Next SourceCell
    Next SourceSheet
    ' 关闭源Excel文件
    SourceWorkbook.Close SaveChanges:=False
    ' 查找下一个源文件
    SourceFilea = Dir
    Loop
    Next
     
    
    ' 关闭并保存目标Excel文件
    OutputWorkbook.SaveAs OutputPath
    OutputWorkbook.Close SaveChanges:=False
    
    MsgBox "数据已提取并保存到" & OutputPath
End Sub
'选择文件夹
Function ChooseFolder() As String
    Dim dlgOpen     As FileDialog

    Set dlgOpen = Application.FileDialog(msoFileDialogFolderPicker)
    With dlgOpen
        If .Show = -1 Then
            ChooseFolder = .SelectedItems(1)
        End If
    End With
    Set dlgOpen = Nothing
End Function

第一版：

Sub ExtractDataFromSpecifiedFilesWithCondition()
    Dim SourcePath As String
    Dim OutputPath As String
    Dim OutputWorkbook As Workbook
    Dim SourceFile As String
    Dim SourceWorkbook As Workbook
    Dim SourceSheet As Worksheet
    Dim LastRow As Long
    Dim NextRow As Long
    Dim SourceCell As Range
    Dim SubFolderPath As String
    Dim SubFolderPathto As String 'ⅰ僢儔儌儂僩僔V儈qqqqqqqqqqq
    Dim asd As String
    Dim qwe As String
    
    SourcePath = ChooseFolder() & "\"
    OutputPath = "D:\11\11.xlsx"
    
    ' 打开或创建目标Excel文件
    On Error Resume Next
    Set OutputWorkbook = Workbooks.Open(OutputPath)
    On Error GoTo 0
    
    If OutputWorkbook Is Nothing Then
        Set OutputWorkbook = Workbooks.Add
    End If
    
    ' 设置目标工作表
敾暿巇敾暿巇條彂斾妑_儗價儏乕qwC:\Users\heyulong\Desktop\崙暿巇條愗懼僔乕儖 -v006.xlsm
    Set OutputSheet = OutputWorkbook.Sheets.Add(After:=OutputWorkbook.Sheets(OutputWorkbook.Sheets.count))
    OutputSheet.Name = "MergedData"
    
    ' 循环处理源文件夹中的每个Excel文件
    SourceFile = Dir(SourcePath & "*巜揈帠崁.xlsx")
    
    Do While SourceFile <> ""
        ' 打开源Excel文件
        Set SourceWorkbook = Workbooks.Open(SourcePath & SourceFile)
        
        ' 循环处理源工作簿中的每个工作表


        For Each SourceSheet In SourceWorkbook.Sheets
            LastRow = SourceSheet.Cells(SourceSheet.Rows.count, "C").End(xlUp).Row
            
            ' 检查每一行的A列，如果包含"指摘"则复制数据
            For Each SourceCell In SourceSheet.Range("C1:C" & LastRow)
                If InStr(1, SourceCell.Value, "xlsx", vbTextCompare) > 0 Then
                    NextRow = OutputSheet.Cells(OutputSheet.Rows.count, "C").End(xlUp).Row + 1
                    SourceSheet.Range("C" & SourceCell.Row).Resize(1, SourceSheet.UsedRange.Columns.count).Copy _
                        Destination:=OutputSheet.Cells(NextRow, 1)
                End If
            Next SourceCell
       Next SourceSheet
        
        ' 关闭源Excel文件
        SourceWorkbook.Close SaveChanges:=False
        
        ' 查找下一个源文件
        SourceFile = Dir
    
    Loop
    '僄儝僞儌儂僩僔V儈儓儈僆僩Excel儂僩僔?
     SubFolderPath = SourcePath & "00_梫媮巇條暘愅\"
    SourceFile = Dir(SubFolderPath & "*巜揈帠崁.xlsx")
    Do While SourceFile <> ""
   'If SourceFile <> "." And SourceFile <> ".." Then
    ' 打开源Excel文件
    Set SourceWorkbook = Workbooks.Open(SubFolderPath & SourceFile)
    ' 循环处理源工作簿中的每个工作表 
    For Each SourceSheet In SourceWorkbook.Sheets
    LastRow = SourceSheet.Cells(SourceSheet.Rows.count, "C").End(xlUp).Row
    ' 检查每一行的A列，如果包含"指摘"则复制数据
    For Each SourceCell In SourceSheet.Range("C1:C" & LastRow)
    If InStr(1, SourceCell.Value, "xlsx", vbTextCompare) > 0 Then
    NextRow = OutputSheet.Cells(OutputSheet.Rows.count, "C").End(xlUp).Row + 1
    SourceSheet.Range("A" & SourceCell.Row).Resize(1, SourceSheet.UsedRange.Columns.count).Copy _
    Destination:=OutputSheet.Cells(NextRow, 1)
    End If
    Next SourceCell
    Next SourceSheet
    ' 关闭源Excel文件
    SourceWorkbook.Close SaveChanges:=False
    ' 查找下一个源文件
    SourceFile = Dir
     
     Loop
    '僄儝僞儌儂僩僔V儈儓儈僆僩Excel儂僩僔?
     SubFolderPathto = SourcePath & "01_峔憿愝寁彂\"
    SourceFile = Dir(SubFolderPathto & "*巜揈帠崁.xlsx")
    Do While SourceFile <> ""
   'If SourceFile <> "." And SourceFile <> ".." Then
    ' 打开源Excel文件
    Set SourceWorkbook = Workbooks.Open(SubFolderPath & SourceFile)
    ' 循环处理源工作簿中的每个工作表 
    For Each SourceSheet In SourceWorkbook.Sheets
    LastRow = SourceSheet.Cells(SourceSheet.Rows.count, "C").End(xlUp).Row
    ' 检查每一行的A列，如果包含"指摘"则复制数据
    For Each SourceCell In SourceSheet.Range("C1:C" & LastRow)
    If InStr(1, SourceCell.Value, "xlsx", vbTextCompare) > 0 Then
    NextRow = OutputSheet.Cells(OutputSheet.Rows.count, "C").End(xlUp).Row + 1
    SourceSheet.Range("A" & SourceCell.Row).Resize(1, SourceSheet.UsedRange.Columns.count).Copy _
    Destination:=OutputSheet.Cells(NextRow, 1)
    End If
    Next SourceCell
    Next SourceSheet
    ' 关闭源Excel文件
    SourceWorkbook.Close SaveChanges:=False
    ' 查找下一个源文件
    SourceFile = Dir
    
    Loop
     '僄儝僞儌儂僩僔V儈儓儈僆僩Excel儂僩僔?
     
     Dim StrFileDir()
    Dim Dic, Path, MyName, Fso, Fs, Fc, F, N, StrPath

    Path = SubFolderPath

    Set Fso = CreateObject("Scripting.FileSystemobject")
    Set Fs = Fso.GetFolder(Path)
    Set Fc = Fs.SubFolders

    For Each F In Fc
      StrPath = Path & F.Name
       N = N + 1
       ReDim Preserve StrFileDir(N)
       StrFileDir(N) = StrPath
    Next

    For i = 1 To UBound(StrFileDir)
     MsgBox StrFileDir(i)
    Next
    
     '僄儝僞儌儂僩僔V儈儓儈僆僩Excel儂僩僔?
     
     Dim StrFileDirto()
    Dim Dicto, Pathto, MyNameto, Fsoto, Fsto, Fcto, Fto, Nto, StrPathto

    Pathto = SubFolderPathto

    Set Fsoto = CreateObject("Scripting.FileSystemobject")
    Set Fsto = Fsoto.GetFolder(Pathto)
    Set Fcto = Fsto.SubFolders

    For Each Fto In Fcto
      StrPathto = Pathto & Fto.Name
       M = M + 1
       ReDim Preserve StrFileDirto(M)
       StrFileDirto(M) = StrPathto
    Next

    For j = 1 To UBound(StrFileDirto)
     MsgBox StrFileDirto(j)
    Next

     For i = 0 To N
     asd = StrFileDir(i) & "\"
    SourceFile = Dir(asd & "*巜揈帠崁.xlsx")
    Do While SourceFile <> ""
   'If SourceFile <> "." And SourceFile <> ".." Then
    ' 打开源Excel文件
    Set SourceWorkbook = Workbooks.Open(asd & SourceFile)
    ' 循环处理源工作簿中的每个工作表 
    For Each SourceSheet In SourceWorkbook.Sheets
    LastRow = SourceSheet.Cells(SourceSheet.Rows.count, "C").End(xlUp).Row
    ' 检查每一行的A列，如果包含"指摘"则复制数据
    For Each SourceCell In SourceSheet.Range("C1:C" & LastRow)
    If InStr(1, SourceCell.Value, "xlsx", vbTextCompare) > 0 Then
    NextRow = OutputSheet.Cells(OutputSheet.Rows.count, "C").End(xlUp).Row + 1
    SourceSheet.Range("A" & SourceCell.Row).Resize(1, SourceSheet.UsedRange.Columns.count).Copy _
    Destination:=OutputSheet.Cells(NextRow, 1)
    End If
    Next SourceCell
    Next SourceSheet
    ' 关闭源Excel文件
    SourceWorkbook.Close SaveChanges:=False
    ' 查找下一个源文件
    SourceFile = Dir
    
    Loop
    Next
    
      For j = 0 To M
     qwe = StrFileDirto(j) & "\"
    SourceFile = Dir(qwe & "*巜揈帠崁.xlsx")
    Do While SourceFile <> ""
   'If SourceFile <> "." And SourceFile <> ".." Then
    ' 打开源Excel文件
    
    
    
    Set SourceWorkbook = Workbooks.Open(qwe & SourceFile)
    
    ' 循环处理源工作簿中的每个工作表 
    For Each SourceSheet In SourceWorkbook.Sheets
    LastRow = SourceSheet.Cells(SourceSheet.Rows.count, "C").End(xlUp).Row
    ' 检查每一行的A列，如果包含"指摘"则复制数据
    For Each SourceCell In SourceSheet.Range("C1:C" & LastRow)
    If InStr(1, SourceCell.Value, "xlsx", vbTextCompare) > 0 Then
    NextRow = OutputSheet.Cells(OutputSheet.Rows.count, "C").End(xlUp).Row + 1
    SourceSheet.Range("A" & SourceCell.Row).Resize(1, SourceSheet.UsedRange.Columns.count).Copy _
    Destination:=OutputSheet.Cells(NextRow, 1)
    End If
    Next SourceCell
    Next SourceSheet
    ' 关闭源Excel文件
    SourceWorkbook.Close SaveChanges:=False
    ' 查找下一个源文件
    SourceFile = Dir
    
    Loop
    Next
     
    
    ' 关闭并保存目标Excel文件
    OutputWorkbook.SaveAs OutputPath
    OutputWorkbook.Close SaveChanges:=False
    
    MsgBox "数据已提取并保存到" & OutputPath
End Sub
'选择文件夹
Function ChooseFolder() As String
    Dim dlgOpen     As FileDialog

    Set dlgOpen = Application.FileDialog(msoFileDialogFolderPicker)
    With dlgOpen
        If .Show = -1 Then
            ChooseFolder = .SelectedItems(1)
        End If
    End With
    Set dlgOpen = Nothing
End Function

以上是我自己做的一些代码，然后定义各种变量，这里要注意的是定义数组StrFileDir()时，后面不要接类型，会报一个类型不匹配的问题

个人见解！！！

若是有更好的方法，记得评论哦！！！

评论
添加红包

请填写红包祝福语或标题

个

红包个数最小为10个

元

红包金额最低5元

当前余额3.43元 前往充值 >
需支付：10.00元
成就一亿技术人!
领取后你会自动成为博主和红包主的粉丝 规则
hope_wisdom
发出的红包
实付元
使用余额支付
点击重新获取
扫码支付
钱包余额 0

抵扣说明：

1.余额是钱包充值的虚拟货币，按照1:1的比例进行支付金额的抵扣。
2.余额无法直接购买下载，可以购买VIP、付费专栏及课程。

余额充值