合并大量工作簿指定单元格数据到一个表

    选择打赏方式

适合大量工作簿合并到一页的VBA宏

特点:宏文件和需要合并的文件是分来的两个文件,不需要保存到个人宏文件也可以可循环使用

也可以下载我已经做好的文件,可以直接使用

使用方法:

1、新建模块,复制代码到模块

2、新建按钮,指定宏文件为刚才的模块

3、新建工作薄,命名为“合并汇总表”

4、点击设置的按钮选择要合并的文件,选择需要合并的区域,开始合并

5、合并的内容在合并汇总表查看


完整代码:


Sub CombineSheetsCells()

    Dim wsNewWorksheet As Worksheet
    Dim cel As Range
    Dim DataSource, RowTitle, ColumnTitle, SourceDataRows, SourceDataColumns As Variant
    Dim TitleRow, TitleColumn As Range
    Dim Num As Integer
    Dim DataRows As Long
    DataRows = 1
    Dim TitleArr()
    Dim Choice
    Dim MyName$, MyFileName$, ActiveSheetName$, AddressAll$, AddressRow$, AddressColumn$, FileDir$, DataSheet$, myDelimiter$
    Dim n, i
    n = 1
    i = 1
    Application.DisplayAlerts = False
    Worksheets("合并汇总表").Delete
    Set wsNewWorksheet = Worksheets.Add(, after:=Worksheets(Worksheets.Count))
    wsNewWorksheet.Name = "合并汇总表"

    MyFileName = Application.GetOpenFilename("Excel工作薄 (*.xls*),*.xls*")

    If MyFileName = "False" Then
    MsgBox "没有选择文件!请重新选择一个被合并文件!", vbInformation, "取消"

    Else

    Workbooks.Open Filename:=MyFileName

    Num = ActiveWorkbook.Sheets.Count
    MyName = ActiveWorkbook.Name
    Set DataSource = Application.InputBox(prompt:="请选择要合并的数据区域:", Type:=8)
    AddressAll = DataSource.Address
    ActiveWorkbook.ActiveSheet.Range(AddressAll).Select

    SourceDataRows = Selection.Rows.Count
    SourceDataColumns = Selection.Columns.Count
    Application.ScreenUpdating = False
    Application.EnableEvents = False

    For i = 1 To Num
    ActiveWorkbook.Sheets(i).Activate
    ActiveWorkbook.Sheets(i).Range(AddressAll).Select
    Selection.Copy

    ActiveSheetName = ActiveWorkbook.ActiveSheet.Name
    Workbooks(ThisWorkbook.Name).Activate
    ActiveWorkbook.Sheets("合并汇总表").Select

    ActiveWorkbook.Sheets("合并汇总表").Range("A" & DataRows).Value = ActiveSheetName
    ActiveWorkbook.Sheets("合并汇总表").Range(Cells(DataRows, 2), Cells(DataRows, 2)).Select

    Selection.PasteSpecial Paste:=xlPasteColumnWidths, Operation:=xlNone, _
    SkipBlanks:=False, Transpose:=False

    Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _
    False, Transpose:=False

    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
    :=False, Transpose:=False

    DataRows = DataRows + SourceDataRows

    Workbooks(MyName).Activate

    Next i

    Application.ScreenUpdating = True

    Application.EnableEvents = True

    End If

    Workbooks(MyName).Close
    End Sub



收录状态:[百度已收录]
版权声明:若无特殊注明,本文皆为《 铜山小皇帝 》原创,转载请保留文章出处。
bet365体育投注188 本文链接:合并大量工作簿指定单元格数据到一个表 http://www.excelbiji.com/vba/46.html
正文到此结束

热门推荐

发表吐槽

你肿么看?

你还可以输入 250 / 250 个字

?嘻嘻 大笑 可怜 吃惊 害羞 调皮 鄙视 示爱 大哭 开心 偷笑 嘘 奸笑 委屈 抱抱 愤怒 思考 日了狗 胜利 不高兴 阴险 乖 酷 滑稽

评论信息框

吃奶的力气提交吐槽中...


既然没有吐槽,那就赶紧抢沙发吧!