Excel-页合并

Posted on | Edited on | In | Views:

Excel—-合并多个 Excel 工作簿至一个工作簿中的工作表

多个工作簿合并到一个工作簿

在由多个工作簿合并到一个工作表之前，需要把多个工作簿合并到一个工作簿。

1、新建一个工作薄，将其命名为合并后的名字，例如叫做：汇总工作簿。
2、打开此工作簿：“汇总工作簿”
3、在“汇总工作簿”下任一个工作表标签上点击右键，选择“查看代码”。
4、在打开的VBA编辑窗口中粘贴以下代码：

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
Sub 工作薄间工作表合并()
Dim FileOpen
Dim X As Integer
Application.ScreenUpdating = False
FileOpen = Application.GetOpenFilename(FileFilter:="Microsoft Excel文件(.xlsx),.xlsx", MultiSelect:=True, Title:="合并工作薄")
X = 1
While X <= UBound(FileOpen)
Workbooks.Open Filename:=FileOpen(X)
Sheets().Move After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count)
X = X + 1
Wend
ExitHandler:
Application.ScreenUpdating = True
Exit Sub
errhadler:
MsgBox Err.Description
End Sub

5、关闭该VBA编辑窗口
6、在Excel中，开发工具—-宏,选“工作薄间工作表合并”,然后“执行”。
7、在打开的对话窗口中，选择你要合并的多个工作薄。
8、等待运行。而后就OK了。
9、打开名为“汇总工作簿”的Excel文件，我们就能看到多个其他工作簿以多个Sheet页的形式合并到了这一个工作簿中。

多个工作表合成一个工作表

在“汇总工作簿”工作簿中，有很多个Sheet页，我们的最终目的是把这多个Sheet页合并到一个Sheet页的多行。其操作办法如下：
1、在“汇总工作簿”中，新建一个sheet页。
2、在新建的sheet标签上单击右键，选择“查看代码”
3、在打开的VBA编辑窗口中粘贴以下代码：

1
2
3
4
5
6
7
8
9
10
11
12
Sub 合并当前工作簿下的所有工作表()
Application.ScreenUpdating = False
For j = 1 To Sheets.Count
If Sheets(j).Name <> ActiveSheet.Name Then
X = Range("A65536").End(xlUp).Row + 1
Sheets(j).UsedRange.Copy Cells(X, 1)
End If
Next
Range("B1").Select
Application.ScreenUpdating = True
MsgBox "当前工作簿下的全部工作表已经合并完毕！", vbInformation, "提示"
End Sub

4、关闭该VBA编辑窗口
5、在Excel中，开发工具—-宏,选“合并当前工作簿下的所有工作表”,然后“执行”。
6、等待运行，而后就OK了。

目录生成

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
Sub getAllWorkSheets()
' 得到所有的sheet页名称，并加上超连接
    totalNum = Worksheets.Count
    Sheet1.Activate
    Range("a:a").Select
   Selection.NumberFormatLocal = "@"

'从2开始就是不带"目录"Sheet页，如果要带，则从1开始
    For index_i = 1 To totalNum
        sheetName = Worksheets(index_i).Name
        Cells(index_i, 1) = sheetName
        tar_sheet = "'" & sheetName & "'"
        Cells(index_i, 1).Select
        ActiveSheet.Hyperlinks.Add Anchor:=Selection, Address:="", SubAddress:= _
        tar_sheet & "!A1", TextToDisplay:=sheetName
    Next index_i
End Sub

目录及返回

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
Function WorkSheetExists(oWB As Workbook, ByVal sWkName As String) As Boolean
    '判断指定名称的工作表是否存在
    'Demo
    'oWB为具体的工作簿,sWkName为工作表的名称,结果返回True表示存在
    On Error Resume Next
    Dim oWK As Worksheet
    Set oWK = oWB.Worksheets(sWkName)
    '如果出错表示不存在指定名称的工作表
    If Err.Number <> 0 Then
        WorkSheetExists = False
    Else
        WorkSheetExists = True
    End If
    Err.Clear
End Function
Sub Demo()
    Excel.Application.DisplayAlerts = False
    On Error Resume Next
    Dim oWK As Worksheet
    Dim oWB As Workbook
    Dim oSp As Shape
    Set oWB = Excel.ActiveWorkbook
   If WorkSheetExists(oWB, "导航目录") = False Then
        Set oWK = oWB.Worksheets.Add(Excel.Worksheets(1))
        oWK.Name = "导航目录"
        oWK.Range("a1") = "目录"
   Else
        Set oWK = oWB.Worksheets("导航目录")
        oWK.Delete
        Set oWK = oWB.Worksheets.Add(Excel.Worksheets(1))
        oWK.Name = "导航目录"
        oWK.Range("a1") = "目录"
   End If
   Dim oWK1 As Worksheet
   i = 2
   For Each oWK1 In oWB.Worksheets
        Dim oRng As Range
        If oWK1.Name <> oWK.Name Then
            oWK1.Shapes("超链接").Delete
            Set oRng = oWK.Range("a" & i)
            sAddress = oWK1.Range("a1").Address(, , , True)
            oWK.Hyperlinks.Add oRng, "", sAddress, , oWK1.Name
            Set oSp = oWK1.Shapes.AddShape(msoShapeBalloon, 0, 0, 50, 30)
            oWK1.Hyperlinks.Add oSp, "", oWK.Range("a1").Address(, , , True), , ""
            oSp.Name = "超链接"
            oSp.TextFrame2.TextRange.Text = "返回"
            i = i + 1
        End If
   Next
   Excel.Application.DisplayAlerts = True
End Sub

按列中条件拆封成多个excel文件

按某A列中分类拆封成多个单独的excel文件

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
Sub 拆分成多个文件()

    '输入用户想要拆分的工作表
    Dim sheet_name
    sheet_name = Application.InputBox("请输入拆分工作表的名称(如Sheet1)：")
    Worksheets(sheet_name).Select

    '输入获取拆分需要的条件列
    Dim col_name
    col_name = Application.InputBox("请输入拆分依据的列号(如A):")

    '输入拆分的开始行，要求输入的是数字
    Dim start_row As Integer
    start_row = Application.InputBox(prompt:="请输入拆分的开始行(如2):", Type:=1)

    '暂停屏幕更新
    Application.ScreenUpdating = False

    '工作表的总行数
    Dim end_row
    end_row = Worksheets(sheet_name).Range("A65536").End(xlUp).Row

    '遍历计算所有拆分表，每个拆分表的格式为"表名称,表行数"
    '对于二维数组，ReDim只能扩充最后一维，因此sheet_map行不变，扩充列
    Dim sheet_map(), sheet_index
    ReDim sheet_map(1, 0)
    sheet_map(0, 0) = Range(col_name & start_row).Value
    sheet_map(1, 0) = 1
    sheet_index = 0

    With Worksheets(sheet_name)
        Dim row_count, temp, i
        row_count = 0
        For i = start_row + 1 To end_row
            temp = Range(col_name & i).Value
            If temp = Range(col_name & (i - 1)).Value Then
                sheet_map(1, sheet_index) = sheet_map(1, sheet_index) + 1
            Else
                ReDim Preserve sheet_map(1, sheet_index + 1)
                sheet_index = sheet_index + 1
                sheet_map(0, sheet_index) = temp
                sheet_map(1, sheet_index) = 1
            End If
        Next
    End With

    '根据前面计算的拆分表，拆分成单个文件
    Dim row_index
    row_index = start_row
    For i = 0 To sheet_index
        Workbooks.Add
        '创建最终数据文件夹
        Dim dir_name
        dir_name = ThisWorkbook.Path & "\拆分出的表格\"
        If Dir(dir_name, vbDirectory) = "" Then
            MkDir (dir_name)
        End If
        '创建新工作簿
        Dim workbook_path
        workbook_path = ThisWorkbook.Path & "\拆分出的表格\" & sheet_map(0, i) & ".xls"
        ActiveWorkbook.SaveAs Filename:=workbook_path, FileFormat:=-4143
        ActiveSheet.Name = sheet_map(0, i)
        '激活当前工作簿，ThisWorkbook表示当前跑代码的工作簿
        ThisWorkbook.Activate

        '拷贝条目数据(即最前面不需要拆分的数据行)
        Dim row_range
        row_range = 1 & ":" & (start_row - 1)
        Worksheets(sheet_name).Rows(row_range).Copy
        Workbooks(sheet_map(0, i) & ".xls").Sheets(1).Range("A1").PasteSpecial
        '拷贝拆分表的专属数据
        row_range = row_index & ":" & (row_index + sheet_map(1, i) - 1)
        Worksheets(sheet_name).Rows(row_range).Copy
        Workbooks(sheet_map(0, i) & ".xls").Sheets(1).Range("A" & start_row).PasteSpecial
        row_index = row_index + sheet_map(1, i)

        '保存文件
        Workbooks(sheet_map(0, i) & ".xls").Close SaveChanges:=True
    Next

    '进行屏幕更新
    Application.ScreenUpdating = True

    MsgBox "拆分工作表完成"

End Sub