精华内容
下载资源
问答
  • excel中利用vba合并多个sheet页和合并多个excel文档
    万次阅读
    2017-07-20 20:33:48

    合并sheet页, 合并excel文档, 合并工作表, 合并工作簿

    合并工作表(sheet)

    合并多个工作表
    仅适用于每个sheet的第一行是数据头,数据从第二行开始。

    Sub 合并工作表()
        Dim J As Integer
        On Error Resume Next
        Sheets(1).Select
        Worksheets.Add
        Sheets(1).Name = "Combined"
        Sheets(2).Activate
        Range("A1").EntireRow.Select
        Selection.Copy Destination:=Sheets(1).Range("A1")
        For J = 2 To Sheets.Count
            Sheets(J).Activate
            c = Sheets(J).Range("IV1").End(xlToLeft).Column
            r = Sheets(J).Range("A65536").End(xlUp).Row
            Range("A2").Resize(r - 1, c).Select
            Selection.Copy Destination:=Sheets(1).Range("A65536").End(xlUp)(2)
        Next
    End Sub
    

    合并工作簿

    
    Sub 合并工作簿()
    
        Dim FileOpen
        Dim X As Integer
        Application.ScreenUpdating = False
        FileOpen = Application.GetOpenFilename(FileFilter:="Excel 97-2003 工作簿(*.xls),*xls,Microsoft Excel文件(*.xlsx),*.xlsx", MultiSelect:=True, Title:="请选择需要合并的工作簿")
        X = 1
        If TypeName(FileOpen) = "Boolean" Then
            MsgBox "未选择任何文件, 退出."
            Exit Sub
        End If
    
        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
    
    更多相关内容
  • VBA - Excel多工作簿合并计算

    因为有人询问合并计算,对VBA略知一些,我就写了一点,有需要的人可以借鉴。

    新建一个工作表,粘贴到模块,F5运行,就可以达到左列合计,左列为一列。

    下面是代码:

    无源数据格式

    Sub 多工作簿合计()
    Application.ScreenUpdating = False
    Dim Wb As Workbook, vrtSelectedItem As Variant, Mysheet As Worksheet, CellAddress
    Dim ShRan As String, Arr() As String, s As Long, Spt, NewPath As String, Bool As Boolean
    On Error Resume Next '遇到错误继续执行
    With Application.FileDialog(msoFileDialogFilePicker)
       .AllowMultiSelect = True
       '多选
      .InitialFileName = ThisWorkbook.Path & "\"
      '默认路径
      .Title = "选择文件"
      '窗口标题
      .Filters.Clear
       '清除文件过滤器
      .Filters.Add "全部文件", "*.*"
      .Filters.Add "Excel文件", "*.xlsm"
      .Filters.Add "Excel文件", "*.xls"
      .Filters.Add "Excel文件", "*.xlsx;*.xls"
       '设置文件过滤器,可以指定多个扩展名,每个扩展名都必须用分号分隔。 例如,可以将参数分配给字符串:".txt;.htm"。
      Cells.Clear
      Bool = True
      If .Show = -1 Then
        For Each vrtSelectedItem In .SelectedItems
          Spt = Split(vrtSelectedItem, "\")
          NewPath = "'" & Replace(vrtSelectedItem, Spt(UBound(Spt)), "[" & Spt(UBound(Spt)) & "]")
          Set Wb = Workbooks.Open(vrtSelectedItem)
          For Each Mysheet In Wb.Worksheets
            '复制标题行,不带格式粘贴
            If Bool Then
              Mysheet.Rows("1:1").Copy
              Cells(1, 1).PasteSpecial Paste:=xlPasteValues
              Bool = False
              Application.CutCopyMode = False
            End If
            ReDim Preserve Arr(s)
            '获取不包含首行的当前区域
            CellAddress = Split(Mysheet.Cells(2, 1).CurrentRegion.Address, ":")
            ShRan = Mysheet.Name & "'!" & Mysheet.Range("A2:" & CellAddress(1)).Address(ReferenceStyle:=xlR1C1) '数据区域
            Arr(s) = NewPath & ShRan
            s = s + 1
          Next Mysheet
          Wb.Close
        Next vrtSelectedItem
        Set Wb = Nothing
      End If
    End With
    Range("A2").Consolidate Sources:=Arr, Function:=xlSum, TopRow:=False, LeftColumn:=True, CreateLinks:=False
    Application.ScreenUpdating = True
    End Sub
    

    下面是有源数据格式的

    Sub 汇总合计() '保留源数据格式
    Application.ScreenUpdating = False
    Dim Wb As Workbook, vrtSelectedItem, Mysheet As Worksheet, i As Long, Bool As Boolean, Start_row
    'On Error Resume Next '容错
    With Application.FileDialog(msoFileDialogFilePicker)
      .AllowMultiSelect = True
       '多选
      .InitialFileName = ThisWorkbook.Path & "\"
      '默认路径
      .Title = "选择文件"
      '窗口标题
      .Filters.Clear
       '清除文件过滤器
      .Filters.Add "全部文件", "*.*"
      .Filters.Add "Excel文件", "*.xlsx;*.xls" '可以指定多个扩展名,每个扩展名都必须用分号分隔。 例如,可以将参数分配给字符串:".txt;.htm"。
      .Filters.Add "Excel文件", "*.xlsm"
      .Filters.Add "Excel文件", "*.xls"
      '设置文件过滤器
      
      Cells.Clear
      Bool = True
      If .Show = -1 Then
        For Each vrtSelectedItem In .SelectedItems
          Set Wb = Workbooks.Open(vrtSelectedItem)
          With ThisWorkbook.ActiveSheet
            For Each Mysheet In Wb.Worksheets
              If Bool = True Then Start_row = 1 Else Start_row = 2: Bool = False
              '获取不包含首行的当前区域
              CellAddress = Split(Mysheet.Cells(1, 1).CurrentRegion.Address, ":")
              Mysheet.Range("A" & Start_row & ":" & CellAddress(1)).Copy .Cells(i + 1, 1)
              
              i = Mysheet.Range("A1").CurrentRegion.Rows.Count
            Next
          End With
          Wb.Close
        Next
        Set Wb = Nothing
      End If
    End With
    
    Dim RowCount As Long, MyRange As String, ColCount As Long, DataCol As Long, E_Coords, Act_sh
    
    With ThisWorkbook.ActiveSheet
        RowCount = .Cells(Rows.Count, 2).End(xlUp).Row
        ColCount = .Cells(1, 1).CurrentRegion.Columns.Count
        Act_sh = .Cells(1, 1).CurrentRegion.Address
        .Range(Act_sh).Copy
            With .Cells(1, ColCount + 1)
               .PasteSpecial Paste:=xlPasteColumnWidths
               .PasteSpecial Paste:=xlPasteFormats
            End With
        Application.CutCopyMode = False
        E_Coords = Split(Act_sh, ":")(1)
        MyRange = ActiveSheet.Name & "!" & .Range("A2:" & E_Coords).Address(ReferenceStyle:=xlR1C1)
        .Cells(2, ColCount + 1).Consolidate Sources:=MyRange, _
                Function:=xlSum, TopRow:=False, LeftColumn:=True, CreateLinks:=False
                
        .Range("A2:" & E_Coords).Delete Shift:=xlToLeft
      
        .Range(Range("A1").CurrentRegion.Rows.Count + 1 & ":" & .Cells.Rows.Count).ClearFormats
    End With
    Application.ScreenUpdating = True
    End Sub

    展开全文
  • VBA学习笔记3:合并同一工作簿下的多个表格

    VBA学习笔记3:合并同一工作簿下的多个表格

    1、建立一个新的汇总表;
    2、将其他sheet数据复制到汇总表中。

    效果如下:
    需要将3个sheet的表的数据汇总起来
    在这里插入图片描述
    汇总后的数据:
    在这里插入图片描述

    代码如下:

    Sub 合并多个工作表数据()
        Dim sht As Worksheet
        Dim rows%, hzrows%  ’row存储被复制的sheet的行数,hzrow存储新建表的行数
        ThisWorkbook.Worksheets().Add(before:=ThisWorkbook.Worksheets("1")).Name = "汇总" 'worksheets.add.name="" 在1月sheet前创建工作表并重命名为“汇总”
        [a1] = "月份"
        [b1] = "姓名"
        [c1] = "成绩"
        For Each sht In Worksheets '循环
            If sht.Name <> ActiveSheet.Name  Then ‘除“汇总”外所有的表都要复制过来
                rows = WorksheetFunction.CountA(sht.[a:a]) 'sheet中a列不为空的行数(注意a列不要有空值)
                hzrows = WorksheetFunction.CountA(ActiveSheet.[a:a]) '“汇总”中的行数(新建表“汇总”即activesheet,也可用worksheets("汇总")替代activesheet)
                sht.Range("a2:b" & rows).Copy ActiveSheet.Range("b" & hzrows + 1) ’将sht的a2及以后的数据复制,粘贴只“汇总”的b列的第一个空行
                Range(Cells(hzrows + 1, 1), Cells(hzrows + rows - 1, 1)) = sht.Name '将sht的表名作为“汇总”的a列值 (从第一份非空行开始,到两个表非空行数-1)
            End If
        Next sht
    End Sub
    

    也可以手工新建“汇总”表后插入按钮,效果如下:

    在这里插入图片描述

    Private Sub CommandButton1_Click()
        ActiveSheet.Range("1:1045876").ClearContents '清空工作簿
        Dim sht As Worksheet
        Dim rows%, hzrows%
        [a1] = "月份"
        [b1] = "姓名"
        [c1] = "成绩"
        For Each sht In Worksheets
            If sht.Name <> ActiveSheet.Name Then
                rows = WorksheetFunction.CountA(sht.[a:a])
                hzrows = WorksheetFunction.CountA(ActiveSheet.[a:a])
                sht.Range("a2:b" & rows).Copy Range("b" & hzrows + 1)
                Range(Cells(hzrows + 1, 1), Cells(hzrows + rows - 1, 1)) = sht.Name
            End If
        Next sht
    End Sub
    
    展开全文
  • VBA代码,可以合并选定的多个Excel文件中的所有工作表到一个文件中(多个工作表)
  • 将同一个工作簿中的所有工作表的内容合并到一个工作表中;新建一个汇总的工作表,并重新自定义命名;2、逐一将各个工作表复制粘贴到汇总工作表中;3、为提示,即当合并工作完成后弹出提示
  • 参考: VBA 合并同文件夹下工作簿中同名工作表到 一工作簿一工作表 2022/1/19 更新 跳过不含指定sheet的工作薄并汇总。 Sub Build_Sheet_List() Dim sht As Worksheet, i As Long, strName As String With Columns...

    参考:
    VBA 合并同文件夹下多工作簿中同名工作表到 一工作簿一工作表

    2022/1/19 更新
    跳过不含指定sheet的工作薄并汇总。

    Sub Build_Sheet_List()
        Dim sht As Worksheet, i As Long, strName As String
        With Columns(1)
            .Clear '清空A列数据
            .NumberFormat = "@" '设置文本格式
        End With
        For i = 1 To Sheets.Count '索引法遍历工作表集合
            strName = Sheets(i).Name '表名
            Cells(i, 1).Value = strName
            ActiveSheet.Hyperlinks.Add anchor:=Cells(i, 1), Address:="", _
                    SubAddress:="'" & strName & "'!a1", TextToDisplay:=strName
        Next
    End Sub
    
    Sub all_excel_files()
        Dim path As String, filename As String
        Dim w As Workbook, ws As Workbook
        With Application.FileDialog(msoFileDialogFolderPicker)
        '-------------------取得用户选择的文件夹路径---------------------------
        If .Show Then path = .SelectedItems(1) Else Exit Sub
        End With
        If Right(path, 1) <> "\" Then path = path & "\"
        filename = Dir(path & "\*.xls*")
        Application.DisplayAlerts = False
        '-------------------取得用户选择的合并工作表名---------------------------
        strKey = InputBox("请输入需要合并的工作表名:", "提醒")
        If StrPtr(strKey) = 0 Then Exit Sub
        '-----------打开指定文件夹下的工作薄,复制粘贴工作表到汇总表,重命名--------------------
        Set ws = Workbooks.Add
        Do While filename <> ""
            'w代表指定文件夹下每个找到的excel文件
            Set w = Workbooks.Open(path & "\" & filename)
                '选择工作表,复制,并粘贴为汇总表的最后一张
              If strKey = ActiveSheet.Name Then
                    w.Sheets(strKey).Copy after:=ws.Sheets(ws.Sheets.Count)
                   ' 重命名刚贴的表名为excel文件名
                    If Right(filename, 4) = "xls*" Then ws.Worksheets(ws.Sheets.Count).Name = Mid(filename, 1, Len(filename) - 4) Else ws.Worksheets(ws.Sheets.Count).Name = Mid(filename, 1, Len(filename) - 5)
                End If
            ' 关闭工作簿
            w.Close
            '下一个
            filename = Dir
        Loop
        '-----------制作目录工作表--------------------
        Sheets("Sheet1").Name = "目录"
        Sheets("目录").Select
        Call Build_Sheet_List
        Application.DisplayAlerts = True
        ws.SaveAs path & "\汇总.xlsx"
    End Sub
    
    

    将所汇总的数据逐个添加到同一工作表中见下载链接:
    https://download.csdn.net/download/weixin_42750611/76744062
    效果如下:
    在这里插入图片描述

    2020/8/10
    在原先代码的基础上修改,可以自由选择和输入要合并多工作簿的同文件夹和工作表名,并生成目录页。
    效果展示:
    1、选择工作表在这里插入图片描述

    2、输入指定相同工作表名

    在这里插入图片描述
    3、等待程序执行完毕。在这里插入图片描述
    代码如下:

    Sub Build_Sheet_List()
        Dim sht As Worksheet, i As Long, strName As String
        With Columns(1)
            .Clear '清空A列数据
            .NumberFormat = "@" '设置文本格式
        End With
        For i = 1 To Sheets.Count '索引法遍历工作表集合
            strName = Sheets(i).Name '表名
            Cells(i, 1).Value = strName
            ActiveSheet.Hyperlinks.Add anchor:=Cells(i, 1), Address:="", _
                    SubAddress:="'" & strName & "'!a1", TextToDisplay:=strName
        Next
    End Sub
    
    Sub all_excel_files()
        Dim path As String, filename As String
        Dim w As Workbook, ws As Workbook
        With Application.FileDialog(msoFileDialogFolderPicker)
        '-------------------取得用户选择的文件夹路径---------------------------
        If .Show Then path = .SelectedItems(1) Else Exit Sub
        End With
        If Right(path, 1) <> "\" Then path = path & "\"
        filename = Dir(path & "\*.xls")
        Application.DisplayAlerts = False
        '-------------------取得用户选择的合并工作表名---------------------------
        strKey = InputBox("请输入需要合并的工作表名:", "提醒")
        If StrPtr(strKey) = 0 Then Exit Sub
        '-----------打开指定文件夹下的工作薄,复制粘贴工作表到汇总表,重命名--------------------
        Set ws = Workbooks.Add
        Do While filename <> ""
            'w代表指定文件夹下每个找到的excel文件
            Set w = Workbooks.Open(path & "\" & filename)
                '选择工作表,复制,并粘贴为汇总表的最后一张
                If strKey <> ActiveSheet.Name Then w.Close
                If strKey <> ActiveSheet.Name Then MsgBox "该文件夹内存在不含指定工作表名的工作薄,请重新检查!", 64, "提示": Exit Sub
                w.Sheets(strKey).Copy after:=ws.Sheets(ws.Sheets.Count)
                 '重命名刚贴的表名为excel文件名
                If Right(filename, 4) = ".xls" Then ws.Worksheets(ws.Sheets.Count).Name = Mid(filename, 1, Len(filename) - 4) Else ws.Worksheets(ws.Sheets.Count).Name = Mid(filename, 1, Len(filename) - 5)
            '关闭工作簿
            w.Close
            '下一个
            filename = Dir
        Loop
        '-----------制作目录工作表--------------------
        Sheets("Sheet1").Name = "目录"
        Sheets("目录").Select
        Call Build_Sheet_List
        Application.DisplayAlerts = True
        ws.SaveAs path & "\汇总.xlsx"
    End Sub
    
    

    小提示:
    1、如果只想打开文件夹内的xlsx文件filename = Dir(path & "\*.xls")改为filename = Dir(path & "\*.xlsx*")可以同时打开文件夹中的xls文件。

    展开全文
  • 在一些操作中,往往会需要将多个工作簿进行合并。一般的操作方法都是打开两个工作簿,然后选中需要移动的工作表,右键单击以后选择“移动或复制”。接下来在新的窗口里面进行设置就可以了。这种方法适合在移动数量较...
  • excel中vba下的代码,合并当前文件夹下所有excel工作表到一新建的工作表中,并将合并的数据进行横向铺开排列。
  • 将某一文件夹下所有工作簿中的张表单汇总到一个工作薄中的一张表单中 最终效果: 步骤流程: 完整代码: ========================================================================= 1、汇总当前...
  • 将同一文件下的多个工作簿的数据汇总为一个工作表
  • 利用Excel进行数据处理分析时,常需要对大量独立的具有相同表结构的原始工作薄中的数据进行汇总合并到一个工作薄的指定工作表中。通过VBA编程调用Excel对象在不打开源工作薄的情况下,将指定文件夹中所有工作薄中的...
  • 应同事需要写了一段VBA代码,实现的功能是把多个Excel文件的第一个工作表(Sheet)合并到一个Excel文件的多个工作表里,并且新工作表的名称等于原Excel文件的文件名。开发环境Excel2010,但是Excel2003应该也能用,...
  • 今天将大家用VBA一键合并,只需要几秒种,为了测试这段代码,我们新建了4个工作簿在文件夹中,数据都是模拟的,做试验一键合并代码操作如下所示:我们看原始表格数据,其中,第1个工作簿有点特殊,这个工作簿中,有...
  • 使用VBA汇总工作表

    2022-05-03 21:24:06
    目的:将一张工作薄中的工作表中的数据记录汇总到一张表中,并统计数据记录条数 如下图所示,将下图中4张工作表中的数据汇总到“汇总表”中 代码实现: (1)该代码是微调宏录制的代码 Sub 核酸汇总() ...
  • 多个excel自动合并到同一表格,该段vba代码的逐句拆解
  • 双击打开汇总文件.xls(当然我们也可以随便新建一excel文档),按ALT+F11打开VBE编辑器,新建一模块,粘贴如下代码:Option ExplicitSub mergeonexls() '合并多工作簿中指定工作表On Error Resume NextDim x As ...
  • 在工作中,我们经常遇到工作表合并到一张工作表的问题,比如希望将图1所示中各分表中保存的成绩记录,汇总到工作簿中的"成绩表"工作表中,可以用图2下面的程序。 图1 七(3)班工作表中的成绩记录 图2汇总...
  • sub 合并当前目录下所有工作簿的全部工作表() dim mypath, myname, awbname dim wb as workbook, wbn as string '字符串类型 String; dim g as long '长整型 Long,占用4字节; dim num as long dim b
  • 对Excel活动工作簿进行合并汇总所有工作表,保存在工作簿最前,适用于同格式 合并工作簿中所有工作表 Sub 合并工作簿中所有工作表() '当前工作簿wb所有工作表ws合并保存至新建工作表(插入最前),但之前ws不修改...
  • 1.同一目录下的工作簿,每个工作簿中有一张或工作表,一键全部汇总 Sub 合并目录所有工作簿全部工作表() Dim MP, MN, AW, Wbn, wn Dim Wb As Workbook Dim i, a, b, d, c, e Application.ScreenUpdating...
  • 那其实也可以把多个工作表合并为一个。 继续之前的例子,我们把汇总表删除 如下 把表 1,2,3 合并到sheet5中 合并代码如下: Sub 合并当前工作簿下的所有工作表() Application.ScreenUpdating = Fals...
  • 我们在实际工作中,有时候需要将多个工作薄中的sheet的数据快速合并到一个sheet表里,假如我们使用手动去复制粘贴,这样就特别浪费时间和精力,所以我们可以使用VBA快速实现,我们只需要输入VBA代码。Sub 合并当前...
  • vba实现excel多表合并

    千次阅读 2020-12-22 11:06:10
    Excel多表合并vba实现需求保留列名,复制每一excel里的数据,合并到一excel操作步骤将要合并的文件放在同一文件夹下,复制过来就好(ps:最好不要直接操作原数据文件,避免操作失败,数据丢失)在这目录下创建...
  • 编辑:哈雷 |来源:巨盒创意 | 欢迎转发到朋友圈日常工作中,我们可能有这样的需求,我们的数据分别存放在N个工作簿里,我们需要把这些零散的数据都移动到一个工作簿里面,而且每张工作表分别存在!我们常用的方法是...
  • 我们需要把多个excel表都放在同一个文件夹里面,并在这个文件夹里面新建...Sub 合并当前目录下所有工作簿的全部工作表() Dim MyPath, MyName, AWbName Dim Wb As Workbook, WbN As String Dim G As Long Dim Num As
  • 如何修改如下代码,可以精准指定合并...Dir Loop Range("a1").Select Application.ScreenUpdating = True MsgBox "共合并了" & a & "个工作薄下全部工作表。如下:" & Chr(13) & Wbn, vbInformation, "提示" End Sub
  • 今天将大家用VBA一键合并,只需要几秒种,为了测试这段代码,我们新建了4个工作簿在文件夹中,数据都是模拟的,做试验一键合并代码操作如下所示:我们看原始表格数据,其中,第1个工作簿有点特殊,这个工作簿中,有...
  • 这是一个常用而且经典的例子:根据内容,把N个工作表中的内容,合并到一个工作表中; ¤主要知识点¤ 1、工作表选取和内容的复制; 2、IF分支语句和For循环语句的使用; ¤代码实例¤ Option Explicit Sub ...
  • 每个工作簿里有多个工作表,需要将两个工作簿指定Sheet工作表(战力值排名)的数据合并在一个新工作簿的新Sheet页里面(新的Sheet页需命名为“数据汇总”); <p>2、新的Sheet...
  • 批量合并excel工作簿中同名工作表,适用条件: 1、所有要汇总的工作簿在同一文件夹中,这里以后缀为.xlsx为例; 2、需要合并工作表名称相同(如: “sheet1”),且数据字段一样(如:A列表示序号,B列表示姓名,...

空空如也

空空如也

1 2 3 4 5 ... 20
收藏数 860
精华内容 344
关键字:

vba汇总多个工作表合并

友情链接: yyjsq.rar