向VBA大神，多张表汇总

2013-04-02

向VBA大神求助，多张表汇总！简单地说我有5张excel表每张表字段都相同，例如：编号，名称，规格。现在我想把这五

向VBA大神求助，多张表汇总！
简单地说我有5张excel表每张表字段都相同，例如：编号，名称，规格。

现在我想把这五张表内容汇总成一张表，第一张表下面接第二张表的数据，之后是第三张，一次类推。

每次对五张表中的一张增加或者修改，合成的那张表就会自动从新生成。

耽误大侠几分钟时间，帮我写个VBA宏，带上注释，给个框架或者关键函数，给思路都行。 vba excel 合成表
[解决办法]
有两种方法
一是直接用SQL查询的汇总
二是用VBA打开文件，复制粘贴到一张表后用透视表

其实你还不如把5个表都放到一个工作簿里得了，然后用数据透视表的合并计算
[解决办法]
只是简单的把五张表的内容叠加式的复制到一张表中吗？还是需要进行汇总呢？
如果只是进行叠加式的复制的话我倒是有一个现成的VBA。

这个是针对文件进行操作的，只要指定了文件名以及相应的表就可以进行合并。
Option Explicit

Sub adddate() '该VBA是打开相应的数据并将相应的表头COPY到相应的文件名称后面。
Dim Filename As String
Dim rownum As Integer
Dim totalrow As Integer
Dim buildtype As String
Dim totalclum
Dim j, i
Dim needrow
Dim btsprice, bscprice, sheetcount, sheetname
'Dim biaoti, shuliang As Range

Application.DisplayAlerts = False
Application.ScreenUpdating = False

totalrow = 0
buildtype = ""
  btsprice = 0
  bscprice = 0
  'Set biaoti = Nothing
  'Set shuliang = Nothing

Windows("test.xlsm").Activate
Sheets(1).Activate

rownum = Sheet1.Range("a1").End(xlDown).Row

For i = 1 To rownum
   Filename = Cells(i, 1).Value

   Workbooks.Open Filename
      sheetcount = Sheets.Count
      For j = 1 To sheetcount
          sheetname = Trim(Sheets(j).Name)

         If Trim(Sheets(j).Name) = "BTSINFO" Then 'btsprice = 1

             Sheets("BTSINFO").Activate
             Cells.EntireColumn.Hidden = False


            totalrow = ActiveSheet.Range("e65535").End(xlUp).Row

            totalclum = ActiveSheet.Range("fc1").End(xlToLeft).Column

            'Debug.Print totalrow, totalclum

            ' ActiveSheet.Range(Cells(1, 5).Address, Cells(1, totalclum).Address)
             'shuliang = ActiveSheet.Range(Cells(totalrow, 5).Address, Cells(totalrow, totalclum).Address)

            'Application.Union(Range(Cells(1, 3).Address, Cells(1, totalclum).Address), Range(Cells(totalrow, 3).Address, Cells(totalrow, totalclum).Address)).Select

             Range(Cells(2, 1).Address, Cells(totalrow, 6).Address).Select
             Selection.Copy


             Windows("test.xlsm").Activate
             Sheets(2).Activate
             needrow = ActiveSheet.Range("a65535").End(xlUp).Row + 1 '这样可保留总计项。
            ' Debug.Print needrow
             Cells(needrow, 1) = Filename
             Cells(needrow + 1, 1).Select
             Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False '按值粘贴
             'Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:=False, Transpose:=True '按转置粘贴
             'Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=True '按值粘贴并转置
             totalrow = 0
             totalclum = 0
             needrow = 0
             btsprice = 0
             bscprice = 0
             ActiveWindow.ActivateNext

           End If
       Next j
   ActiveWindow.Close

  Windows("test.xlsm").Activate
  Sheets(1).Activate

Next i

Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub

[解决办法]
怎么我都没有编辑自己帖子的权限
判断更新运行宏示例
Private Sub Worksheet_Change(ByVal Target As Range)
adddate
End Sub
假设三楼的宏就是你要的

热点排行

OFFICE教程

向VBA大神，多张表汇总