拆分和合并excel表 VBA

1. 拆分到表

说明：运行后需要输入两个值，如下为值的说明

1. 第一个需要输入的值：如果是需要从A列分类拆分表，请输入A

2. 第二个需要输入的值：表头默认第1行，如果表头是第二行的，请输入2

注意：拆分后将生成"被拆分文件的当前文件夹"下的"excel文件名+时间戳"的文件夹中

' 运行此函数即可
Sub 拆分到表()

Dim sht As Worksheet
Dim k, i, j As Integer
Dim irow As Long '活动目录有最下面的行数
Dim l, t As Integer
Dim sht0 As Worksheet

Set sht0 = ActiveSheet

l = InputBox("请输入你要按哪列分，例如A列，请输入A")
t = InputBox("请输入表头所在的行,默认表头为第1行", Default:=1)

'将列名转为列号
l = Range("A1:" & l & "1").Cells.Count

'将输入的列转为数字，字符串乘以1，即可转为数字类型
l = l * 1
t = t * 1

'删除无意义的表,当前活动表除外
Application.DisplayAlerts = False
If Sheets.Count > 1 Then
    For Each sht1 In Sheets
        If sht1.Name <> sht0.Name Then
            sht1.Delete
        End If
    Next
End If
Application.DisplayAlerts = True

'将要拆分的列新建单独的sheet,去重
irow = sht0.Range("a1048576").End(xlUp).Row
For i = t+1 To irow
    k = 0
    For Each sht In Sheets	'循环sheets表，取表名，跟当前输入的列值对比，如果相同，那么记录K=1
        If sht.Name = sht0.Cells(i, l) Then
            k = 1
        End If
    Next

    If k = 0 Then	'当K=0的时候，也就是跟所有的sheets表不同，那么就是新表，在最后创建，表明为该列的值
        Sheets.Add after:=Sheets(Sheets.Count)
        Sheets(Sheets.Count).Name = sht0.Cells(i, l)
    End If

Next

'拷贝数据
crow = Sheet1.Range("a" & t).End(xlToRight).Column	'最后一列列数
crowName = Replace(Cells(1, crow).Address(0, 0), "1", "")	'最后一列的列号，需要拷贝的数据为表头的数据
For j = 2 To Sheets.Count
    sht0.Range("a" & t & ":" & crowName & irow).AutoFilter Field:=l, Criteria1:=Sheets(j).Name
    sht0.Range("a1:" & crowName & irow).Copy Sheets(j).Range("a1")
Next

sht0.Range("a" & t & ":" & crowName & irow).AutoFilter

'执行完之后，回到当前激活的表
sht0.Select

call 拆分到文件

End Sub


'拆分到文件 函数 此函数无需运行，请运行上面的函数即可
Sub 拆分到文件()

Dim sht As Worksheet
Dim wb As Workbook

'设置当前活动表和工作簿为变量，并获取工作簿的名字
Set sht0 = ActiveSheet
Set wb = ActiveWorkbook
wbName = Left(wb.Name, InStrRev(wb.Name, ".") - 1)
'创建以时间命名的文件夹，并将其赋予变量pp
pp = wb.Path & "\" & wbName & "_" & Format(Now, "YYYY-M-D_hh_nn_ss")
MkDir pp

'禁止实时刷新
Application.ScreenUpdating = False

'循环每张表，并将其另存为新的Excel
For Each sht In Sheets
	If sht.Name <> sht0.Name Then	'如果不等于当前活动的表，那么就拆分文件到刚才以时间命名的文件夹中，也就是当前文件下会有时间命名的文件夹
        sht.Copy
        ActiveWorkbook.SaveAs Filename:=pp & "\" & sht.Name & "_" & wbName & ".xlsx"
        ActiveWorkbook.Close
     End If
Next
'启动实时刷新
Application.ScreenUpdating = True

'执行完之后，回到当前激活的表
sht0.Select
msgbox "合并文件成功！！！"
End Sub

2. 合并excel表

• 注意：第一个需要输入的值：表头默认有1行，如果表头有二行，请输入2
• 会自动获取表头，无需自动填充表头

Sub 文件数据合并()
Dim str()
Dim header As Integer
Dim wb As Workbook
Dim sht, sht_act As Worksheet
Dim irow, jrow, i As Long   'irow是数据源表的最后一行，jrow是目标表(数据表)的最后一行
Dim fileToOpen
'关闭闪屏和不保存提示
Application.ScreenUpdating = False
Application.DisplayAlerts = False
header = InputBox("请输入表头所在的行,默认表头为第1行", Default:=1)
'将输入的列转为数字，字符串乘以1，即可转为数字类型
header = header * 1

On Error Resume Next '防止点了取消发生的错误
Set sht_act = ActiveSheet  '当前活动的工作表

'清理当前活动的工作表A行到最后一行的所有数据,除了表头，此处表头为header行
airow = sht_act.Range("a1048576").End(xlUp).Row
If airow > header Then
    sht_act.Rows(header + 1 & ":" & airow).ClearContents
End If

'开始进行合并，弹出窗口让用户选择excel文件，并强制了是xls后缀的文件才能被选择
fileToOpen = Application.GetOpenFilename("Excel数据文件,*.xls*", , , , True)

'粘贴表头
Set wb_one = Workbooks.Open(fileToOpen(1))
wb_one_col = wb_one.Sheets(1).UsedRange.Columns.Count
wb_one.Sheets(1).Range("a1").Resize(header, wb_one_col).Copy sht_act.Cells(1, 1)
wb_one.Close

    For i = LBound(fileToOpen) To UBound(fileToOpen)  '循环打开的表
        Set wb = Workbooks.Open(fileToOpen(i))     '赋予变量为表
        For Each sht In wb.Sheets   '循环表内的数据，确保只有一张表，根据上面拆分的表为准
            If sht.FilterMode = True Then
                Selection.AutoFilter    '如果有筛选则取消掉
            End If
            sht_col = sht.UsedRange.Columns.Count   '列数
            sht_row = sht.UsedRange.Rows.Count - header  '行数，减去表头
            jrow = sht_act.Range("a1048576").End(xlUp).Row + 1
            sht.Range("a" & header + 1).Resize(sht_row, sht_col).Copy sht_act.Cells(jrow, 1)
        Next
        wb.Close
    Next
    
'自动行高和列宽
sht_act.Columns.AutoFit
sht_act.Rows.AutoFit

'恢复闪屏和保存提示
Application.ScreenUpdating = True
Application.DisplayAlerts = True
MsgBox "合并文件成功！！！"
End Sub