复杂的多工作簿指定区域有数据的分表才逐一添加数据到汇总文件指定位置

peter-chen · 发表于 2023-5-19 15:05

zpy2 发表于 2023-5-19 08:31
就是遍历文件夹和子文件夹吗孙文件夹？论坛搜索一下有不少的。

关键你的需求，我也是没看明白。

需求有图片和对应结果的文件效果，见附件和图片
1、让这个合计文件去统计该文件夹下（包括里面的所有子文件夹内）的所有EXCEL工作薄文件中的所有表中的A4:D15和G4:I15到合计文件中的19行后的指定列中去，（所有表格A4:D15的数据来源于自身表19行后的数据统计，其中有时会有人误操作建立新表，但是新表中A4:D15中没有至少2行有数据的不纳入统计拷贝数据！）
2、对应工作薄名+工作表名显示在对应19行后的O列内，难点是以这个为内容生成可以直接打开该数据对应文件的链接！见附件，假设这个合计文件是放在d:\TEST4-EXCELHOME， O20显示内容数据来源于“A2022预算\预算11月”（即A2022预算工作薄里的预算11月表格），同时自动生成链接指向文件表所在地方，点击这个内容就直接打开相应文件的对应表，比如这里链接就为d:\TEST4-EXCELHOME\A2022预算.xls，点击时可以直接打开.

3、其他数据不处理。
不指定文件所在路径，不管文件在哪，只要是合计文件所有的文件夹就执行该合计文件所在路径下(包括里面的每一个子文件夹内的）的所有EXCEL文件的以上数据追加汇总。

peter-chen · 发表于 2023-5-19 15:28

Sub SummarizeData()
Dim summaryWorksheet As Worksheet
Dim currentWorksheet As Worksheet
Dim currentWorkbook As Workbook
Dim currentWorkbookPath As String
Dim currentWorkbookName As String
Dim currentWorksheetName As String
Dim startRow As Long
Dim startColumn As Long
Dim endRow As Long
Dim endColumn As Long
Dim currentRow As Long
Dim currentColumn As Long
Dim isDataValid As Boolean
Dim totalRowCount As Long
Dim totalColumnCount As Long
Dim rowOffset As Long
Dim columnOffset As Long
Dim mergedRange As Range
Dim rowValues(1 To 12) As Variant
Dim columnValues(1 To 15) As Variant
   '清空A20:O68856
Dim SHX As Worksheet
      Set SHX = Sheets("合计数据")
SHX.Range("A20:o68856").ClearContents

'获取合计文件所在的文件夹路径
currentWorkbookPath = ThisWorkbook.Path

'获取合计文件的工作表
Set summaryWorksheet = ThisWorkbook.Worksheets("合计数据")

'定位数据追加的起始行和列
startRow = summaryWorksheet.Cells(Rows.Count, "O").End(xlUp).Row + 1
startColumn = 2

'遍历该文件夹及其子文件夹中的所有Excel文件
currentWorkbookName = Dir(currentWorkbookPath & "\*.xls*")
Do While currentWorkbookName <> ""
      '判断当前文件是否为合计文件
      If currentWorkbookName <> ThisWorkbook.Name Then
         '打开当前文件
         Set currentWorkbook = Workbooks.Open(currentWorkbookPath & "\" & currentWorkbookName)
         For Each currentWorksheet In currentWorkbook.Worksheets
            currentWorksheetName = currentWorksheet.Name
            isDataValid = False

            '判断当前工作表的特定区域是否符合条件
            For currentRow = 4 To 15
                  For currentColumn = 1 To 9
                     If Not IsEmpty(currentWorksheet.Cells(currentRow, currentColumn)) Then
                        isDataValid = True
                        Exit For
                     End If
                  Next currentColumn
                  If isDataValid Then Exit For
            Next currentRow

            '如果符合条件，则复制对应数据到合计文件中
            If isDataValid Then
                  rowOffset = 0
                  '复制A4:A15到对应B列中
                  columnOffset = 0
                  For currentRow = 4 To 15
                     If Not IsEmpty(currentWorksheet.Cells(currentRow, 1)) Then
                        rowOffset = rowOffset + 1
                        rowValues(rowOffset) = currentWorksheet.Cells(currentRow, 1)
                        columnValues(columnOffset + startColumn) = currentWorksheet.Cells(currentRow, 1)
                        columnOffset = columnOffset + 1
                     End If
                  Next currentRow
                  '通过复制B4:L15到对应B、K、L列中
                  For currentColumn = 2 To 12
                     isDataValid = False
                     For currentRow = 4 To 15
                        If Not IsEmpty(currentWorksheet.Cells(currentRow, currentColumn)) Then
                              isDataValid = True
                              Exit For
                        End If
                     Next currentRow
                     If isDataValid Then
                        For currentRow = 4 To 15
                              If currentColumn = 2 Then
                                 rowValues(rowOffset + currentRow - 3) = currentWorksheet.Cells(currentRow, currentColumn)
                              End If
                              columnValues(columnOffset + startColumn) = currentWorksheet.Cells(currentRow, currentColumn)
                              columnOffset = columnOffset + 1
                        Next currentRow
                     End If
                  Next currentColumn

                  '在合计文件中定位到数据追加的起始行和列
                  endRow = startRow + rowOffset - 1
                  endColumn = startColumn + columnOffset - 2

                  '复制数据并合并单元格
                  Set mergedRange = summaryWorksheet.Range(summaryWorksheet.Cells(startRow, 1), summaryWorksheet.Cells(endRow, 1))
                  mergedRange.Merge
                  mergedRange.Value = currentWorkbookName & " - " & currentWorksheetName
                  summaryWorksheet.Range(summaryWorksheet.Cells(startRow, startColumn), summaryWorksheet.Cells(endRow, endColumn)).Value = columnValues
                  mergedRange.Offset(0, 10).Formula = "=SUM(" & summaryWorksheet.Cells(startRow, 11).Address & ":" & summaryWorksheet.Cells(endRow, 11).Address & ")"
                  mergedRange.Offset(0, 11).Formula = "=SUM(" & summaryWorksheet.Cells(startRow, 12).Address & ":" & summaryWorksheet.Cells(endRow, 12).Address & ")"
            End If
         Next currentWorksheet
         '关闭当前文件
         currentWorkbook.Close False
      End If
      '获取下一个文件名
      currentWorkbookName = Dir()
Loop

'给出操作完成提示
MsgBox "数据汇总已完成！", vbInformation
End Sub

错误是什么原因？？谢谢

wanao2008 · 发表于 2023-5-20 06:54

遍历目录及文件的代码如下：

Dim arr$(), k&
Sub test()
Erase arr
k = 0
GetAllFiles ThisWorkbook.Path
Stop
End Sub
Sub GetAllFiles(myPath$)
Dim Fld As Object, f, fd, m$, n$
Set Fld = CreateObject("Scripting.FileSystemObject").GetFolder(myPath)
For Each f In Fld.Files
m = f.Name
If m Like "*.xls*" Then
If Left(m, 2) <> "~$" And m <> ThisWorkbook.Name Then
k = k + 1
ReDim Preserve arr(1 To k)
arr(k) = myPath & "" & m
End If
End If
Next
For Each fd In Fld.subfolders
n = fd.Name
GetAllFiles myPath & "" & n
Next
End Sub

复制代码

如有任何疑问，可看视频教学：
https://www.bilibili.com/video/BV17z4y1b7JD/

peter-chen · 发表于 2023-5-20 16:56

wanao2008 发表于 2023-5-20 06:54
遍历目录及文件的代码如下：

收到，回去测试，谢谢你的回复

wanao2008 · 发表于 2023-5-20 21:30

用于完成你的要求的完整代码如下：

Option Explicit
Dim arr(), k&
Sub byWanao()
Dim i&, j&, wb As Workbook, sht As Worksheet, jsNum&, rowNum&
Application.ScreenUpdating = False
Call TestFindAllFiles
rowNum = 19
Sheet1.Range("A20:O65536").ClearContents
For k = 1 To UBound(arr)
Set wb = GetObject(arr(k))
For Each sht In wb.Sheets
jsNum = 0
If sht.Range("A15") <> "" Or sht.Range("A15").End(xlUp).Row > 4 Then
For j = 1 To 9 Step 6
For i = 4 To 15
If sht.Cells(i, j) = "" Then Exit For
jsNum = jsNum + 1
rowNum = rowNum + 1
With Sheet1
.Cells(rowNum, 1) = jsNum
.Cells(rowNum, 2) = sht.Cells(i, j)
If j = 1 Then
.Cells(rowNum, "k") = sht.Cells(i, j + 2)
.Cells(rowNum, "l") = sht.Cells(i, j + 3)
Else
.Cells(rowNum, "k") = sht.Cells(i, j + 1)
.Cells(rowNum, "l") = sht.Cells(i, j + 2)
End If
.Cells(rowNum, "m") = "=L" & rowNum & "-K" & rowNum
.Cells(rowNum, "n") = "=M" & rowNum & "/K" & rowNum
.Hyperlinks.Add Anchor:=.Cells(rowNum, "o"), Address:=arr(k), _
TextToDisplay:=wb.Name & "" & sht.Name
End With
Next
Next
End If
Next
Stop
wb.Close savechanges:=False
Set wb = Nothing
Next
Application.ScreenUpdating = True
End Sub
Sub TestFindAllFiles()
Erase arr
k = 0
FindAllFiles ThisWorkbook.Path
End Sub
Sub FindAllFiles(fsPath$)
Dim fs, f, fd, m$, n$
Set fs = CreateObject("Scripting.FileSystemObject").getFolder(fsPath)
For Each f In fs.Files
If f.Name Like "*.xls*" Then
If Left(f.Name, 2) <> "~$" And f.Name <> ThisWorkbook.Name Then
k = k + 1
ReDim Preserve arr(1 To k)
arr(k) = fsPath & "" & f.Name
End If
End If
Next
For Each fd In fs.subfolders
FindAllFiles fsPath & "" & fd.Name
Next
End Sub

复制代码

如果有任何疑问，可看教学视频：
https://www.bilibili.com/video/BV1qs4y1M7od/

如果解决了你的问题，请给朵小红花！

yuyubiao · 发表于 2023-5-21 00:23

解决了吗？

peter-chen · 发表于 2023-5-21 10:40

wanao2008 发表于 2023-5-20 06:54
遍历目录及文件的代码如下：

不好意思昨天晚上外出陪孩子了，我现在测试，测试前先送花

peter-chen · 发表于 2023-5-21 11:11

wanao2008 发表于 2023-5-20 21:30
用于完成你的要求的完整代码如下：

如果有任何疑问，可看教学视频：

我给你的回复不见了？？审核中？？？
谢谢您的回复，我测试了下，我是WIN10,OFFICE 2010 & OFFICE 2019，出错在：
Set fs = CreateObject("Scripting.FileSystemObject").GetFolder(fsPath)
显示是：
运行时错误“76”
路径未找到

我等会修改下，我看看代码先。谢谢

peter-chen · 发表于 2023-5-21 11:13

yuyubiao 发表于 2023-5-21 00:23
解决了吗？

还在测试，我想不断通过一个例子把相关的都搞懂，我自己也写了个，但是没有去实现遍历子文件夹和文件名+表名生成对应的文件链接

peter-chen · 发表于 2023-5-21 11:26

yuyubiao 发表于 2023-5-21 00:23
解决了吗？

其实这个也可以看成时大部分将数据合并到某个总表后，又从总表反填数据到另外一个总表的指定区域（可以理解为指定区域其实就是汇总前的每个分表的数据合计表），谢谢您过来指点

		自动登录	找回密码
密码			免费注册

[求助] 复杂的多工作簿指定区域有数据的分表才逐一添加数据到汇总文件指定位置

评分

评分