欧美bbbwbbbw肥妇,免费乱码人妻系列日韩,一级黄片

Excel·VBA合并工作簿的實現(xiàn)示例

 更新時間:2023年06月05日 08:41:59   作者:薛定諤_51  
本文主要介紹了Excel·VBA合并工作簿的實現(xiàn)示例,文中通過示例代碼介紹的非常詳細,對大家的學習或者工作具有一定的參考學習價值,需要的朋友們下面隨著小編來一起學習學習吧

1,合并文件夾下所有工作簿

適用將所有工作簿中所有工作表復制到1個新建工作簿中,不修改數(shù)據(jù),原本一共有多少個工作表,合并后就有多少個工作表
如果存在同名工作表,復制后工作表名稱會自動添加序號,如Sheet1 (2)

Sub 合并文件夾下所有工作簿()
    '文件夾下所有工作簿wb所有工作表ws合并為一個新工作簿(但不含子文件夾),不修改數(shù)據(jù)
    Dim write_wb As Workbook, wb As Workbook, sht As Worksheet, file_path$, file_name$
    file_path = "E:\測試\拆分表\"  '待合并工作簿所在的文件夾
    file_name = Dir(file_path & "*.xlsx")
    Application.ScreenUpdating = False  '關閉屏幕更新,加快程序運行
    Application.DisplayAlerts = False   '不顯示警告信息
    Set write_wb = Workbooks.Add    '新建工作簿,合并文件
    Do While file_name <> ""
        Set wb = Workbooks.Open(file_path & file_name)
        For Each sht In wb.Worksheets
            sht.Copy After:=write_wb.Sheets(write_wb.Sheets.Count)
        Next
        wb.Close (False)
        file_name = Dir  '下一個文件名
    Loop
    '保存文件
    save_file = file_path & "合并表.xlsx"
    write_wb.SaveAs filename:=save_file
    write_wb.Close (False)
    Application.ScreenUpdating = True
    Application.DisplayAlerts = True
End Sub

1.1,合并且建立超鏈接目錄

Sub 合并文件夾下所有工作簿并建立目錄()
    '文件夾下所有工作簿wb所有工作表ws合并為一個新工作簿(但不含子文件夾),不修改數(shù)據(jù),并建立目錄超鏈接
    Dim write_wb As Workbook, wb As Workbook, list_ws As Worksheet, sht As Worksheet
    Dim fso As Object, file_path$, file_name$, full_name$, newname$, w&
    file_path = "E:\測試\拆分表\"  '待合并工作簿所在的文件夾
    file_name = Dir(file_path & "*.xlsx")
    Application.ScreenUpdating = False  '關閉屏幕更新,加快程序運行
    Application.DisplayAlerts = False   '不顯示警告信息
    Set write_wb = Workbooks.Add    '新建工作簿,合并文件
    Set list_ws = write_wb.Worksheets(1): list_ws.Name = "目錄"
    list_ws.Cells(1, 1) = "目錄(原工作簿名-工作表名)": list_ws.Cells(1, 2) = "超鏈接": w = 1
    Set fso = CreateObject("Scripting.FileSystemObject")
    Do While file_name <> ""
        Set wb = Workbooks.Open(file_path & file_name)
        For Each sht In wb.Worksheets
            sht.Copy After:=write_wb.Sheets(write_wb.Sheets.Count)
            full_name = fso.GetBaseName(file_name) & "-" & sht.Name  '原工作簿名-工作表名
            'write_wb.Sheets(write_wb.Sheets.Count).Name = full_name  '可對復制的ws重命名
            w = w + 1: list_ws.Cells(w, 1) = full_name: newname = write_wb.Sheets(write_wb.Sheets.Count).Name
            list_ws.Hyperlinks.Add anchor:=list_ws.Cells(w, 2), Address:="", SubAddress:="'" & newname & "'!a1", TextToDisplay:=newname
        Next
        wb.Close (False)
        file_name = Dir  '下一個文件名
    Loop
    '保存文件
    list_ws.Columns(1).AutoFit  '列寬自適應
    save_file = file_path & "合并表.xlsx"
    write_wb.SaveAs filename:=save_file
    write_wb.Close (False)
    Application.ScreenUpdating = True
    Application.DisplayAlerts = True
End Sub

舉例

合并《Excel·VBA按列拆分工作表》,sub2拆分后的工作表

在這里插入圖片描述

并且每個工作簿中的工作表復制1個副本(1個地名表1個Sheet1表),這樣就有5個工作簿各含2個工作表
工作簿合并且建立超鏈接目錄結(jié)果

在這里插入圖片描述

2,合并工作簿中所有工作表

對工作簿中相同格式的工作表進行合并,匯總所有工作表,保存在工作簿最前

2.1,縱向合并

Sub 合并工作簿中所有工作表_縱向()
    '當前工作簿wb所有工作表ws合并保存至新建工作表(插入最前),但之前ws不修改(工作表格式相同)
    Dim wb, ws, title_row, end_row, copy_title, i
'--------------------參數(shù)填寫:title_row,數(shù)字,第1行為1向下遞增;end_row,數(shù)字
    title_row = 1  '表頭行數(shù),僅復制1次;如果為0,則表示沒有表頭或表頭每次都復制
    end_row = 0    '表尾行數(shù),不參與合并
    Set wb = Application.ActiveWorkbook  '當前工作簿即為待合并工作簿
    Set ws = wb.Worksheets.Add(before:=Sheets(1))  '最前添加新sheet,即為合并工作表
    ws.Name = "合并表"
    If title_row > 0 Then copy_title = True Else copy_title = False  '是否復制表頭
    If title_row < 0 Then Debug.Print "title_row參數(shù)錯誤,必須為>=0的整數(shù)": Exit Sub
    Application.ScreenUpdating = False  '關閉屏幕更新,加快程序運行
    Application.DisplayAlerts = False   '不顯示警告信息
    '遍歷,復制表體
    For i = 1 To Worksheets.count:
        If Worksheets(i).Name <> ws.Name Then
            If copy_title = True Then  '復制表頭,僅執(zhí)行1次
                Worksheets(i).Rows(1 & ":" & title_row).Copy ws.Range("A1")
                copy_title = False
            End If
            '首行為空,會導致后續(xù)數(shù)據(jù)被覆蓋
            If WorksheetFunction.CountA(ws.Rows(1)) = 0 Then ws.Rows(1).Delete
            write_row = ws.UsedRange.Rows.count + 1  '合并工作表的第一個空行寫入
            sheet_row = Worksheets(i).UsedRange.Rows.count
            Worksheets(i).Rows(title_row + 1 & ":" & sheet_row - end_row).Copy ws.Range("A" & write_row)
        End If
    Next
    Application.ScreenUpdating = True
    Application.DisplayAlerts = True
End Sub

舉例

合并《Excel·VBA按列拆分工作表》,sub1拆分后的工作表

在這里插入圖片描述

在這里插入圖片描述

合并參數(shù):title_row = 1,end_row = 0

在這里插入圖片描述

在這里插入圖片描述

2.2,橫向合并

Sub 合并工作簿中所有工作表_橫向()
    '當前工作簿wb所有工作表ws合并保存至新建工作表(插入最前),但之前ws不修改(工作表格式相同)
    Dim ws As Worksheet, sht As Worksheet, write_col&
    Application.ScreenUpdating = False  '關閉屏幕更新,加快程序運行
    Application.DisplayAlerts = False   '不顯示警告信息
    With ActiveWorkbook
        Set ws = .Worksheets.Add(before:=Sheets(1))  '最前添加新sheet,即為合并工作表
        ws.Name = "合并表"
        For Each sht In .Worksheets
            If sht.Name <> ws.Name Then
                '首列為空時,會導致后續(xù)數(shù)據(jù)被覆蓋
                If WorksheetFunction.CountA(ws.Columns(1)) = 0 Then ws.Columns(1).Delete
                write_col = ws.UsedRange.Columns.Count + 1
                sht.UsedRange.Copy ws.Cells(1, write_col)
            End If
        Next
    End With
    Application.ScreenUpdating = True
    Application.DisplayAlerts = True
End Sub

舉例

合并前

在這里插入圖片描述

合并后

在這里插入圖片描述

3,合并文件夾下所有工作簿中所有工作表

對相同格式的工作簿進行合并,匯總所有工作表,保存為單獨工作簿

Sub 合并文件夾下所有工作簿中所有工作表()
    '文件夾下所有工作簿wb所有工作表ws合并保存至新建工作表(但不含子文件夾),但不修改原數(shù)據(jù)(工作表格式相同)
    Dim wb, ws, title_row, end_row, copy_title, file_path, file_name, save_file, i
'--------------------參數(shù)填寫:title_row,數(shù)字,第1行為1向下遞增;end_row,數(shù)字;file_path,合并文件夾
    title_row = 1  '表頭行數(shù),僅復制1次;如果為0,則表示沒有表頭或表頭每次都復制
    end_row = 0    '表尾行數(shù),不參與合并
    file_path = "E:\測試\拆分表\"  '待合并工作簿所在的文件夾
    file_name = Dir(file_path & "*.xlsx") 
    If title_row > 0 Then copy_title = True Else copy_title = False  '是否復制表頭
    If title_row < 0 Then Debug.Print "title_row參數(shù)錯誤,必須為>=0的整數(shù)": Exit Sub
    Application.ScreenUpdating = False  '關閉屏幕更新,加快程序運行
    Application.DisplayAlerts = False   '不顯示警告信息
    Workbooks.Add    '新建工作表
    Set ws = ActiveSheet
    ws.Name = "合并表"
    Do While file_name <> ""
        Set wb = Workbooks.Open(file_path & file_name)
        For i = 1 To Worksheets.count:
            If copy_title = True Then  '復制表頭,僅執(zhí)行1次
                wb.Worksheets(i).Rows(1 & ":" & title_row).Copy ws.Range("A1")
                copy_title = False
            End If
            '首行為空,會導致后續(xù)數(shù)據(jù)被覆蓋
            If WorksheetFunction.CountA(ws.Rows(1)) = 0 Then ws.Rows(1).Delete
            write_row = ws.UsedRange.Rows.count + 1  '合并工作表的第一個空行寫入
            sheet_row = wb.Worksheets(i).UsedRange.Rows.count
            wb.Worksheets(i).Rows(title_row + 1 & ":" & sheet_row - end_row).Copy ws.Range("A" & write_row)
        Next
        wb.Close (False)
        file_name = Dir  '下一個文件名
    Loop
    '保存文件
    save_file = file_path & "合并表.xlsx"
    ws.Parent.SaveAs filename:=save_file
    ws.Parent.Close (False)
    Application.ScreenUpdating = True
    Application.DisplayAlerts = True
End Sub

舉例

合并《Excel·VBA按列拆分工作表》,sub2拆分后的工作表

在這里插入圖片描述

合并參數(shù):title_row = 0,end_row = 0

在這里插入圖片描述

在這里插入圖片描述

3.1,合并且顯示原工作簿名稱、原工作表名稱

應評論建議,增加在A列顯示原工作簿名稱,B列顯示原工作表名稱

Sub 合并文件夾下所有工作簿中所有工作表1()
    '文件夾下所有工作簿wb所有工作表ws合并保存至新建工作表(但不含子文件夾),但不修改原數(shù)據(jù)(工作表格式相同)
    Dim wb, ws, title_row, end_row, copy_title, file_path, file_name, save_file, fso As Object
'--------------------參數(shù)填寫:title_row,數(shù)字,第1行為1向下遞增;end_row,數(shù)字;file_path,合并文件夾
    title_row = 1  '表頭行數(shù),僅復制1次;如果為0,則表示沒有表頭或表頭每次都復制
    end_row = 0    '表尾行數(shù),不參與合并
    file_path = "E:\測試\拆分表\"  '待合并工作簿所在的文件夾
    file_name = Dir(file_path & "*.xlsx")
    If title_row > 0 Then copy_title = True Else copy_title = False  '是否復制表頭
    If title_row < 0 Then Debug.Print "title_row參數(shù)錯誤,必須為>=0的整數(shù)": Exit Sub
    Application.ScreenUpdating = False  '關閉屏幕更新,加快程序運行
    Application.DisplayAlerts = False   '不顯示警告信息
    Set fso = CreateObject("Scripting.FileSystemObject")
    Workbooks.Add    '新建工作表
    Set ws = ActiveSheet: ws.Name = "合并表": ws.Cells(1, "a").Resize(1, 2) = Array("原工作簿名稱", "原工作表名稱")
    Do While file_name <> ""
        Set wb = Workbooks.Open(file_path & file_name)
        For Each sht In wb.Worksheets
            If copy_title = True Then  '復制表頭,僅執(zhí)行1次
                sheet_col = sht.UsedRange.Columns.count
                sht.Range(Cells(1, "a"), Cells(title_row, sheet_col)).Copy ws.Cells(1, "c")
                copy_title = False
            End If
            If WorksheetFunction.CountA(ws.Rows(1)) = 0 Then ws.Rows(1).Delete
            write_row = ws.UsedRange.Rows.count + 1  '合并工作表的第一個空行寫入
            sheet_row = sht.UsedRange.Rows.count: sheet_col = sht.UsedRange.Columns.count
            sht.Range(Cells(title_row + 1, "a"), Cells(sheet_row - end_row, sheet_col)).Copy ws.Cells(write_row, "c")
            ws.Cells(write_row, "a").Resize(sheet_row - title_row - end_row, 2) = Array(fso.GetBaseName(file_name), sht.Name)
        Next
        wb.Close (False)
        file_name = Dir  '下一個文件名
    Loop
    '保存文件
    save_file = file_path & "合并表.xlsx"
    ws.Parent.SaveAs filename:=save_file
    ws.Parent.Close (False)
    Application.ScreenUpdating = True
    Application.DisplayAlerts = True
End Sub

4,合并文件夾下所有工作簿中同名工作表

對工作簿按工作表名稱進行合并,匯總所有同名工作表,保存為單獨工作簿

Sub 合并文件夾下所有工作簿中同名工作表()
    '文件夾下所有工作簿wb所有工作表ws按名稱合并保存至新建工作表(但不含子文件夾),但不修改原數(shù)據(jù)(工作表格式相同)
    Dim dict As Object, sht As Worksheet, file_path$, file_name$, title_row, end_row, save_file$
'--------------------參數(shù)填寫:title_row,數(shù)字,第1行為1向下遞增;end_row,數(shù)字;file_path,合并文件夾
    title_row = 1  '表頭行數(shù),不參與合并
    end_row = 0    '表尾行數(shù),不參與合并
    file_path = "E:\測試\拆分表\"  '待合并工作簿所在的文件夾
    file_name = Dir(file_path & "*.xlsx")
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    Set dict = CreateObject("scripting.dictionary")
    Set write_wb = Workbooks.Add    '新建工作簿,合并文件
    '新建工作簿默認工作表,防止有同名被合并表,導致整表復制后名稱改變;但會缺少表頭
    For Each sht In write_wb.Worksheets
        dict(sht.Name) = ""
    Next
    Do While file_name <> ""
        Set wb = Workbooks.Open(file_path & file_name)
        For Each sht In wb.Worksheets
            If Not dict.Exists(sht.Name) Then  '不存在的,直接復制整表
                dict(sht.Name) = ""
                sht.Copy After:=write_wb.Sheets(write_wb.Sheets.count)
            Else
                Set write_ws = write_wb.Worksheets(sht.Name)
                '首行為空,會導致后續(xù)數(shù)據(jù)被覆蓋
                If WorksheetFunction.CountA(write_ws.Rows(1)) = 0 Then write_ws.Rows(1).Delete
                write_row = write_ws.UsedRange.Rows.count + 1  '合并工作表的第一個空行寫入
                sheet_row = sht.UsedRange.Rows.count
                sht.Rows(title_row + 1 & ":" & sheet_row - end_row).Copy write_ws.Range("A" & write_row)
            End If
            'Exit Do
        Next
        wb.Close (False)
        file_name = Dir  '下一個文件名
    Loop
    '保存文件
    save_file = file_path & "合并表.xlsx"
    write_wb.SaveAs filename:=save_file
    write_wb.Close (False)
    Application.ScreenUpdating = True
    Application.DisplayAlerts = True
End Sub

4.1,合并且顯示原工作簿名稱

應評論建議,增加在A列顯示原工作簿名稱;因按同名工作表合并,故沒有顯示原工作表名稱的必要

Sub 合并文件夾下所有工作簿中同名工作表1()
    '文件夾下所有工作簿wb所有工作表ws按名稱合并保存至新建工作表(但不含子文件夾),但不修改原數(shù)據(jù)(工作表格式相同)
    Dim dict As Object, sht As Worksheet, fso As Object
    Dim file_path$, file_name$, title_row, end_row, save_file$
'--------------------參數(shù)填寫:title_row,數(shù)字,第1行為1向下遞增;end_row,數(shù)字;file_path,合并文件夾
    title_row = 1  '表頭行數(shù),不參與合并
    end_row = 0    '表尾行數(shù),不參與合并
    file_path = "E:\測試\拆分表\"  '待合并工作簿所在的文件夾
    file_name = Dir(file_path & "*.xlsx")
    Application.ScreenUpdating = False  '關閉屏幕更新,加快程序運行
    Application.DisplayAlerts = False   '不顯示警告信息
    Set fso = CreateObject("Scripting.FileSystemObject")
    Set dict = CreateObject("scripting.dictionary")
    Set write_wb = Workbooks.Add    '新建工作簿,合并文件
    '新建工作簿默認工作表,防止有同名被合并表,導致整表復制后名稱改變;但會缺少表頭
    For Each sht In write_wb.Worksheets
        dict(sht.Name) = "": [a1] = "原工作簿名稱"
    Next
    Do While file_name <> ""
        Set wb = Workbooks.Open(file_path & file_name)
        For Each sht In wb.Worksheets
            If Not dict.Exists(sht.Name) Then  '不存在的,直接復制整表
                dict(sht.Name) = ""
                sht.Copy After:=write_wb.Sheets(write_wb.Sheets.count)
                ActiveSheet.Columns(1).Insert: [a1] = "原工作簿名稱"  '插入列
                Range("a2:a" & ActiveSheet.UsedRange.Rows.count).Value = fso.GetBaseName(file_name)  '需要擴展名可直接賦值file_name
            Else
                Set write_ws = write_wb.Worksheets(sht.Name)
                If WorksheetFunction.CountA(write_ws.Rows(1)) = 0 Then write_ws.Rows(1).Delete
                write_row = write_ws.UsedRange.Rows.count + 1  '合并工作表的第一個空行寫入
                sheet_row = sht.UsedRange.Rows.count: sheet_col = sht.UsedRange.Columns.count
                sht.Range(Cells(title_row + 1, "a"), Cells(sheet_row - end_row, sheet_col)).Copy write_ws.Range("B" & write_row)
                write_ws.Cells(write_row, "a").Resize(sheet_row - title_row - end_row) = fso.GetBaseName(file_name)
            End If
        Next
        wb.Close (False)
        file_name = Dir  '下一個文件名
    Loop
    '保存文件
    save_file = file_path & "合并表.xlsx"
    write_wb.SaveAs filename:=save_file
    write_wb.Close (False)
    Application.ScreenUpdating = True
    Application.DisplayAlerts = True
End Sub

到此這篇關于Excel·VBA合并工作簿的實現(xiàn)示例的文章就介紹到這了,更多相關Excel VBA合并工作簿內(nèi)容請搜索腳本之家以前的文章或繼續(xù)瀏覽下面的相關文章希望大

相關文章

  • VBA解決Windows空當接龍的617局

    VBA解決Windows空當接龍的617局

    本文給大家分享的是使用VBA解決Windows空當接龍的617局的方法和思路,有需要的小伙伴可以參考下。
    2015-09-09
  • excel vba 高亮顯示當前行代碼

    excel vba 高亮顯示當前行代碼

    用條件格式設置高亮顯示當前行,難的是如何確定當前行。用VBA就很簡單,鼠標右擊工作表標簽,選擇“查看代碼”,將下面的代碼粘貼到VBE窗口中
    2009-07-07
  • VBA工程加密PJ方式(兩種)

    VBA工程加密PJ方式(兩種)

    今天遇到一個excel小工具感覺不錯,想研究研究代碼,竟然有密碼,我就不淡定了。網(wǎng)上找了找代碼,改了一下就OK了。接下來通過本文給大家分享兩種方式破解VBA工程加密,需要的朋友參考下吧
    2021-12-12
  • vba將excel按照某一列拆分成多個文件

    vba將excel按照某一列拆分成多個文件

    本文主要介紹了vba將excel按照某一列拆分成多個文件,文中通過示例代碼介紹的非常詳細,對大家的學習或者工作具有一定的參考學習價值,需要的朋友們下面隨著小編來一起學習學習吧<BR>
    2023-01-01
  • 向數(shù)據(jù)報表添加一個合計字段

    向數(shù)據(jù)報表添加一個合計字段

    在數(shù)據(jù)環(huán)境設計器中也可以創(chuàng)建一個合計字段,即對來自部分的數(shù)據(jù)進行合計的字段。
    2009-07-07
  • excel vba 限制工作表的滾動區(qū)域代碼

    excel vba 限制工作表的滾動區(qū)域代碼

    如果希望限制工作表中滾動的區(qū)域,可以通過設置WorkSheet對象的ScrollArea屬性來實現(xiàn)。
    2009-07-07
  • VBA中Excel宏的介紹及應用

    VBA中Excel宏的介紹及應用

    本文主要介紹了VBA中Excel宏的介紹及應用,文中通過示例代碼介紹的非常詳細,對大家的學習或者工作具有一定的參考學習價值,需要的朋友們下面隨著小編來一起學習學習吧
    2023-05-05
  • VBA 瀏覽文件夾對話框調(diào)用的幾種方法

    VBA 瀏覽文件夾對話框調(diào)用的幾種方法

    VBA 瀏覽文件夾對話框調(diào)用實現(xiàn)代碼。大家可以根據(jù)需要選擇。
    2009-07-07
  • Excel?VBA按列拆分工作表和工作簿的實現(xiàn)

    Excel?VBA按列拆分工作表和工作簿的實現(xiàn)

    表格拆分是常見的數(shù)據(jù)處理,本文主要介紹了Excel?VBA按列拆分工作表和工作簿的實現(xiàn),文中通過示例代碼介紹的非常詳細,對大家的學習或者工作具有一定的參考學習價值,需要的朋友們下面隨著小編來一起學習學習吧
    2023-01-01
  • VBA數(shù)組去重(字典去重多種方法+數(shù)組去重2種方法)

    VBA數(shù)組去重(字典去重多種方法+數(shù)組去重2種方法)

    本文主要介紹了VBA數(shù)組去重(字典去重多種方法+數(shù)組去重2種方法),文中通過示例代碼介紹的非常詳細,對大家的學習或者工作具有一定的參考學習價值,需要的朋友們下面隨著小編來一起學習學習吧
    2023-08-08

最新評論