|
|
楼主 |
发表于 2018-10-23 20:06
|
显示全部楼层
[广告] Excel易用宝 - 提升Excel的操作效率 · Excel / WPS表格插件 ★ 免费下载 ★ ★ 使用帮助★
本帖最后由 liuxi001 于 2018-10-26 10:07 编辑
- Sub 多薄多表合并()
- Dim zTab(1 To 65535, 1 To 100), fTab, zTitle, 总表表头行, 总表列数, 分表表头行, 分表尾行
- Dim sh As Worksheet, Wb As Workbook, 选择 As Range, 分表尾单元格 As Range, dic
- Set dic = CreateObject("scripting.dictionary")
- '获取总表表头行号、列数
- '************************************************************
- '方法1：鼠标单击选择表头行
- ' On Error Resume Next
- ' Set 选择 = Application.InputBox("请选择总表表头所在行的任意单元格", "选择", Type:=8)
- ' On Error GoTo 0
- ' If 选择 Is Nothing Then
- ' Exit Sub
- ' Else
- ' 总表表头行 = Val(Split(选择.Address, "$")(2))
- ' End If
- '************************************************************
- '方法2：总表第一行为表头
- 总表表头行 = 1
- '************************************************************
- zTitle = Range(Cells(总表表头行, 1), Cells(总表表头行, Cells(总表表头行, Columns.Count).End(xlToLeft).Column)).Value
- If Not IsArray(zTitle) Then
- Exit Sub
- Else
- 总表列数 = UBound(zTitle, 2)
- End If
- t = Timer
- '设置循环目录
- p = ThisWorkbook.Path & ""
- F = Dir(p & "*.xls*")
- Application.ScreenUpdating = False
- '工作薄名不为空时循环
- Do While F <> ""
- '工作薄名和总表文件名相同则跳过
- If F <> ThisWorkbook.Name Then
- Set Wb = GetObject(p & F)
- '工作表循环
- For Each sh In Wb.Sheets
- '****************************************************
- '分表表头行号'出现次数最多的为表头行,防止其它行有与表头有相似名称
- For j = 1 To 总表列数
- Set fTany = sh.Range("1:100").Find(zTitle(1, j), , xlFormulas, xlPart, xlByRows, xlNext)
- If Not fTany Is Nothing Then
- dic(fTany.Row) = dic(fTany.Row) + 1
- End If
- Next
- For Each ele In dic.keys
- If dic(ele) = Application.Max(dic.items) Then
- 分表表头行 = ele
- Exit For
- End If
- Next
- dic.RemoveAll
- '****************************************************
- '分表列数、尾行、数据
- Set 分表尾单元格 = sh.Cells.Find("*", , xlFormulas, xlPart, xlRows, xlPrevious)
- If Not 分表尾单元格 Is Nothing Then
- 分表尾行 = 分表尾单元格.Row
- 分表列数 = sh.Cells(分表表头行, sh.Columns.Count).End(xlToLeft).Column
- fTab = sh.Range(sh.Cells(分表表头行, 1), sh.Cells(分表尾行, 分表列数)).Value
- 分表行数 = UBound(fTab, 1)
- ReDim ztofcol(1 To 总表列数)
- '*************************************************
- '总表表头在分表中的列号(ztofcol)
- For i = 1 To 总表列数
- For j = 1 To 分表列数
- If fTab(1, j) <> "" Then
- If ztofcol(i) = 0 And (InStr(zTitle(1, i), fTab(1, j)) > 0 Or InStr(fTab(1, j), zTitle(1, i)) > 0) Then
- ztofcol(i) = j
- '在分表中找到表头后计数
- TitleCnt = TitleCnt + 1
- Exit For
- End If
- End If
- Next
- Next
- '*************************************************
- '分表无表头列
-
- '待增功能，合并分表中无表头的列数据
- '*************************************************
- n = n + 1
- '分表数据写入总表数组
- If TitleCnt > 0 Then
- For i = 2 To 分表行数
- m = m + 1
- For j = 1 To 总表列数
- If Not IsEmpty(ztofcol(j)) Then
- zTab(m, j) = fTab(i, ztofcol(j))
- End If
- Next
- zTab(m, 2) = Left(Wb.Name, InStr(Wb.Name, ".") - 1) & "_" & sh.Name
- zTab(m, 1) = m
- Next
- '清空分表表头与总表表头对应关系数组
- Erase ztofcol
- TitleCnt = 0
- End If
- End If
- Next
- Workbooks(F).Close False
- End If
- F = Dir
- Loop
- If m > 0 Then
- Cells(总表表头行 + 1, 1).Resize(Rows.Count - 总表表头行, Columns.Count).ClearContents
- '*****************************************************
- '设置文本格式,超过15位的数字建议设置文本格式
- Range("A:B").NumberFormat = "@"
- '*****************************************************
- Cells(总表表头行, 1) = "序号"
- Cells(总表表头行, 2) = "数据来源"
- Cells(总表表头行 + 1, 1).Resize(m, 总表列数 + 2) = zTab
- End If
- Application.ScreenUpdating = True
- Cells(11, 总表列数 + 2) = "共合并了" & n & "个文件，" & m & "行数据。" & "用时：" & Format(Timer - t, "0.00") & "秒"
- Cells(12, 总表列数 + 2) = "说明：1.把此工作薄复制到要合并的文件夹下；"
- Cells(13, 总表列数 + 2) = " 2.在本表中填写好要合并的列字段名称，例如本表的第1行；"
- Cells(14, 总表列数 + 2) = " 3.不限制分表的表头位置和顺序，但是分表要合并的列字段名要与总表相同(可以是包含关系，如客户姓名—姓名）"
- Cells(15, 总表列数 + 2) = " 4.支持EXCEL2003，如果数据超过65536行请选择2007版或以上版本,并自行修改数组声明zTab(1 To 1000000, 1 To 100)"
- End Sub
- Sub cl()
- Range(Cells(2, 1), Cells(Rows.Count, Columns.Count)).ClearContents
- End Sub
补充内容 (2019-4-30 01:02):
这段代码废了，直接24楼 |
评分
-
3
查看全部评分
-
|
[复制链接]
沪公网安备 31011702000001号 沪ICP备11019229号-2
发表于 2018-10-19 01:21
发表于 2018-11-14 15:45
