楼主
0Mouse |
Q：如何运用VBA将每个子表指定位置的数据均排成一行依次填入总表中呢？
示例：
子表1：
子表2：
子表3：
总表汇总结果：（列数太多，截图中部分列被隐藏）
注：3个子表中，红色矩形框框住的区域内选项选取方式存在差异，分别为“■”、“√”（勾）和“V”（大写字母V）。
A：代码如下：- Sub 汇总()
- Application.ScreenUpdating = False '关闭屏幕更新
- Dim fp$, fn$, arr, i%, j%, brr, rg As Range, k As Byte, sr1$, sr2$ '定义变量
- fp = ThisWorkbook.Path & "\" '将汇总表文件所在路径赋值给fp变量
- fn = Dir(fp & "*.xlsx") '获取路径下的Excel文件的文件名
- arr = [A1].CurrentRegion '将汇总表A1单元格所在区域数据赋值给arr
- For k = 1 To UBound(arr, 2) '循环arr数组的每一列
- If arr(1, k) = "" Then arr(1, k) = arr(1, k - 1) '将数组第一行各列空值填入与其左侧相同的内容
- Next
- ReDim brr(1 To 1000, 1 To UBound(arr, 2)) '重新定义brr数组两个维度的上下限
- Do While fn <> "" '循环路径下的各个工作簿，直到fn为空
- If fn <> ThisWorkbook.Name Then '如果不是本工作簿
- i = i + 1
- Workbooks.Open fp & fn '打开Dir返回的文件名对应的Excel文档
- For j = 1 To UBound(arr, 2) '循环arr数组的每一列
- With ActiveWorkbook.Sheets(1)
- Set rg = .Cells.Find(arr(2, j)) '查找arr数组第二行各列的数值，并用rg代表找到的单元格
- If arr(1, j) = "基本情况" Or arr(1, j) = "转型前" Or arr(1, j) = "特殊指标" Then
- If arr(2, j) = "人员人数（人）" Then
- brr(i, j) = rg.Offset(, 2) '找到的单元格往右偏移2列
- Else
- brr(i, j) = rg.Offset(, 1)
- End If
- ElseIf arr(1, j) = "转型后" Then
- If arr(2, j) = "人员人数（人）" Then
- brr(i, j) = rg.Offset(, 8)
- Else
- brr(i, j) = rg.Offset(, 1).Offset(, 1)
- End If
- Else
- sr1 = Replace(rg.Offset(, 1), " ", " ") '通过替换增加空格数
- sr2 = Replace(rg.Offset(, 1), " ", "") '通过替换删除空格数
- If InStr(1, rg.Offset(, 1), "■") Then
- brr(i, j) = Trim(Mid(sr1, InStr(1, sr1, "■") + 1, 4)) '将sr1变量中从“■”下一个字符开始的连续4个字符去除首尾多余空格后赋值给brr(i,j)
- ElseIf Split(sr2, "□")(0) = "" Then
- brr(i, j) = Split(sr2, "□")(2)
- Else
- brr(i, j) = Split(sr2, "□")(1)
- End If
- sr1 = "": sr2 = "" '清空sr1和sr2变量
- End If
- End With
- Next
- ActiveWorkbook.Close False '关闭活动工作簿，不保存
- End If
- fn = Dir '获取下一个文件名
- Loop
- [A3].Resize(i, UBound(arr, 2)).ClearContents '清空目标区域数据
- [A3].Resize(i, UBound(arr, 2)) = brr '将brr数组存储的数据写入目标区域
- Erase brr: Erase arr '清空数组变量
- Application.ScreenUpdating = True '开启屏幕更新
- End Sub
附件：
 运用VBA将每个子表指定位置的数据均排成一行依次填入总表中.rar
|
