|
|
[广告] VBA代码宝 - VBA编程加强工具 · VBA代码随查随用 · 内置多项VBA编程加强工具 ★ 免费下载 ★ ★ 使用手册★
各位大佬，小弟初来乍到，请多关照，工作中经常遇到需要把几年的表（每月1张表）合并到一起，但有个别月的表的列名会多几列或少几列，不是完全一致，我找到一段VBA代码（我是一点VBA也不懂），合并表的时候，如果遇到新的标题列，向汇总表中添加新列，这样就得出一张完整的合并数据表，这样虽可以解决我合并表的问题，但是我发现，合并之后例如身份证这样的数字，会变成科学计数。大佬们，能不能帮我改改这段代码，最好是生成的汇总表所有字段全部为文本类型的。
Sub 工作表汇总() '汇总不同标题行的工作表
Dim ws As Worksheet, sht As Worksheet
Dim lastRow As Long, lastCol As Long
Dim i As Long, j As Long, k As Long
Dim headerDict As Object
'添加一个新工作表作为汇总表
Set ws = ThisWorkbook.Sheets.Add
ws.Name = "总表"
'创建一个字典对象，用于存储标题和列号
Set headerDict = CreateObject("scripting.Dictionary")
'初始化行号
k = 1
'遍历每个工作表
For Each sht In ThisWorkbook.Sheets
If sht.Name <> ws.Name Then
'找到数据的最后一行和最后一列
lastRow = sht.UsedRange.Rows(sht.UsedRange.Rows.Count).Row
lastCol = sht.Cells(1, sht.Columns.Count).End(xlToLeft).Column
'处理第一个工作表，复制标题
If k = 1 Then
For j = 1 To lastCol
headerDict(sht.Cells(1, j).Value) = j
ws.Cells(1, j).Value = sht.Cells(1, j).Value
Next j
k = k + 1
End If
'将数据复制到汇总表
For i = 2 To lastRow
For j = 1 To lastCol
'如果遇到新的标题列，向汇总表中添加新列
If Not headerDict.Exists(sht.Cells(1, j).Value) Then
headerDict(sht.Cells(1, j).Value) = ws.Cells(1, ws.Columns.Count).End(xlToLeft).Column + 1
ws.Cells(1, headerDict(sht.Cells(1, j).Value)).Value = sht.Cells(1, j).Value
End If
ws.Cells(k, headerDict(sht.Cells(1, j).Value)).Value = sht.Cells(i, j).Value
Next j
k = k + 1
Next i
End If
Next sht
End Sub
|
|
沪公网安备 31011702000001号 沪ICP备11019229号-2
发表于 2024-8-28 21:52
楼主
