VBA汇总多表后提示本次共汇总了多少数据的代码

Option Explicit

Sub HuiZong()

    Dim myfile, mypath, wb               '声明变量

    ApplicationScreenUpdating = False   '关闭屏幕更新

    Sheet1UsedRangeOffset(1, 0)Clear  '清除除表头之外的所有内容

    mypath = ThisWorkbookPath           '找到当前工作簿的路径

    myfile = Dir(mypath & "\xls")     '遍历当前文件夹下的Excel文件

    Do While myfile <> ""                '当找到的文件不为空时

        If myfile <> ThisWorkbookName Then   '当找到的文件不是当前Excel工作簿时

            n = n + 1

            Set wb = GetObject(mypath & "\" & myfile)   '得到dir找到的工作簿的内容，设为wb

            With wbSheets(1)              '对找到的工作簿的sheet1进行操作

                 nr = UsedRangeRowsCount - 1 + nr

                UsedRangeOffset(1, 0)Copy Sheet1Range("A" & Sheet1UsedRangeRowsCount + 1)  '复制wb的sheet1除第一行的所有内容, Offset(1, 0),

            End With

            wbClose False      '关闭wb工作簿且不保存

        End If

        myfile = Dir          '寻找下一个Excel工作簿

    Loop

    ApplicationScreenUpdating = True   '恢复屏幕更新

    MsgBox "汇总完成" & vbCrLf & "汇总了" & n & "个工作表" & vbCrLf & "汇总了" & nr & "行数据" & vbCrLf & "请保存文件再关闭！"

End Sub

可以在Excel表格中用下面的VBA程序实现：

Sub Test() '打开当前目录下文件，将Sheet1信息复制到汇总表上

Dim f$

Dim n&

Mypath = ThisWorkbookPath & "\"

f = Dir(Mypath & "xls")

Do While f > " "

n = n + 1

WorkbooksOpen Mypath & f

Set c = ActiveWorkbook

arr=sheet1UsedRange

cClose

Cells(n, 1)resze(Ubound(arr,1),Ubound(arr,2)) =arr

n=n+Ubound(arr,1)

f = Dir

Loop

End Sub

昨天回答了，答案被度娘吃了

今天再来过：

一、

首先把你的那几个EXCEL文件复制到同一个目录下，全选，按F2，把第一个文件重命名为

(0)xls，这样你所有的文件就都变为这个形式的了

(0)xls，(1)xls，(2)xls，(3)xls，

二、新建一个excel文档，录制一个宏，什么都不做就结束录制，然后把这个宏的代码改成如下样子：

Sub Macro1()

'

' Macro1 Macro

' 宏由 JalYou 录制，时间: 2011/10/11

'

' 快捷键: Ctrl+j

'

Dim tmpname, dir, selfname

Dim nRow, nCur, i, j

nCur = 1

selfname = ActiveWorkbookname

dir = ActiveWorkbookPath & "\"

For i = 0 To 6 '把这句话改成你实际的文件数量，如(0)xls(100)xls，就改成For i = 0 To 100

tmpname = "(" & i & ")xls"

WorkbooksOpen dir & tmpname

nRow = Workbooks(tmpname)Sheets("sheet1")Range("A65535")End(xlUp)Row

For j = 1 To nRow

Workbooks(selfname)Sheets("sheet1")Range("A" & nCur)Value = Workbooks(tmpname)Sheets("sheet1")Range("A" & j)Value

nCur = nCur + 1

Next j

Workbooks(tmpname)Close

Next i

End Sub

sheets(1)range("A2:A"&sheets(1)range("A65536")end(xlup)row)copy sheets("汇总表")range("A2")

后面的range("A2")写你要粘贴的区域的第一个单元格。

例子数据源：

程序代码：

运行结果：

是不是很完美，程序文本：

Option Explicit

Sub 转换()

    Dim a1, a2(1 To 1000, 1 To 100), i, j, x, y, m, n

    Set x = CreateObject("ScriptingDictionary")

    Set y = CreateObject("ScriptingDictionary")

    a1 = Range("a1")CurrentRegion

    For i = 1 To UBound(a1)

        If a1(i, 1) = "价格" Then

            If Not yExists(a1(i, 2)) Then

                a2(1, yCount + 2) = a1(i, 2)

                yAdd a1(i, 2), yCount + 2

            End If

            n = y(a1(i, 2))

        Else

            If Not xExists(a1(i, 1)) Then

                a2(xCount + 2, 1) = a1(i, 1)

                xAdd a1(i, 1), xCount + 2

            End If

            m = x(a1(i, 1))

            a2(m, n) = a1(i, 2)

        End If

    Next i

    Range("d1")Resize(xCount + 1, yCount + 1) = a2

End Sub

Sub Macro1()

Dim MyPath$, MyName$, sh As Worksheet, sht As Worksheet

ApplicationScreenUpdating = False

Set sh = ActiveSheet

MyPath = ThisWorkbookPath & "\"

MyName = Dir(MyPath & "xls")

[a1]CurrentRegionOffset(2)Clear

Do While MyName <> ""

If MyName <> ThisWorkbookName Then

With GetObject(MyPath & MyName)

For Each sht In Sheets

If shtName <> "总表" Then

If sht[a65536]End(3)Row > 3 Then

lr = sh[a65536]End(3)Row + 1

r = sht[a65536]End(3)Row - 3

shCells(lr, 1)Resize(r) = Split(MyName, "")(0)

shCells(lr, 2)Resize(r) = shtName

'sht[a1]CurrentRegionOffset(3, 7)Copy shCells(lr, 3)

shtRange("A4:G" & (r + 3))Copy shCells(lr, 3)

End If

End If

Next

Close False

End With

End If

MyName = Dir

Loop

ApplicationScreenUpdating = True

MsgBox "ok"

End Sub

lr = Sheets("基本表")Range("a17")End(xlUp)Row 改成 lr = Sheets("基本表")Range("a65536")End(xlUp)Row

WorkbooksOpen myPath & myFile 后 Sheets("基本表") 为刚打开的excel的 Sheets("基本表") ，最好把它写全，前面加workbooks（"xls"）

myFile = Dir

'再用dir函数提取一个文件名

Loop

myFile = Dir

没有代码无法调试，以上3处试试吧

'打开文件在菜栏有一个"表格汇总"按扭

Sub auto_open()

MenuBars(xlWorksheet)Reset

Set mycommandbar = CommandBars("standard")

Set mybutton = mycommandbarControlsAdd(Type:=msoControlButton)

With mybutton

Style = msoButtonCaption

Caption = "表格汇总"

Enabled = True

OnAction = "ABCD"

End With

End Sub

Sub auto_close()

Set mycommandbar = CommandBars("standard")

For Each mybutton In mycommandbarControls

If mybuttonCaption = "表格汇总" Then mybuttonDelete

Next

End Sub

Sub ABCD()

Dim lj As String

Dim dirname As String

Dim nm As String

Sheets(1)Select

lj = ActiveWorkbookPath

nm = ActiveWorkbookName

dirname = Dir(lj & "\")

Range("A2:AD200")Select

SelectionDelete Shift:=xlToLeft

Do While dirname <> ""

If dirname <> nm Then

WorkbooksOpen Filename:=lj & "\" & dirname

Workbooks(nm)Activate

Workbooks(dirname)Sheets(1)Range("Q5:AD5")Copy _

Sheets(1)Range("a65536")End(xlUp)Offset(2, 0)'自己的表格修改

Workbooks(dirname)Close False

End If

dirname = Dir

Loop

Cells(20, 1)Select

End Sub