IntelliJ IDEA extjs6.5 macos events timer interface datepicker angular ui router GMU jquery去除空格 erp项目描述 oracle删除表字段 js回调函数写法 maven配置eclipse eclipse显示左边目录 Navicat python教学 python操作mongodb pythonlist java基础 javarandom java集合转数组 jdk环境配置 java删除 html实例教程 asp建站系统 vs2010sp1 js刷新页面 u盘系统下载 骰子动态图 cubase下载 俄罗斯方块代码 python延时函数 相册制作工具 黑客入门新手特训 sqlprompt 联盟练级路线 软碟通u盘装系统教程 苹果x怎么用 php定时任务
当前位置: 首页 > 学习教程  > 编程语言

3.常用VBA 合并不同工作簿所有工作表到一张工作表

2021/1/28 23:00:32 文章标签:

命令从下面第一个Sub开始: Sub 合并当前目录下所有工作簿的全部工作表() Dim MyPath, MyName, AWbNameDim Wb As Workbook, WbN As StringDim G As Long, k As IntegerDim Num As LongDim BOX As StringApplication.ScreenUpdating FalseMyPath ActiveWorkbook.…

命令从下面第一个Sub开始:

Sub 合并当前目录下所有工作簿的全部工作表()

Dim MyPath, MyName, AWbName

Dim Wb As Workbook, WbN As String

Dim G As Long, k As Integer

Dim Num As Long

Dim BOX As String

Application.ScreenUpdating = False

MyPath = ActiveWorkbook.Path

MyName = Dir(MyPath & "\" & "*.xls")

AWbName = ActiveWorkbook.Name

Num = 0

ii = 0

Do While MyName <> ""

    If MyName <> AWbName Then

        Set Wb = Workbooks.Open(MyPath & "\" & MyName)

        Num = Num + 1

        With Workbooks(1).ActiveSheet

            .Cells(.Range("B" & Rows.Count).End(xlUp).Row + 1, 1) = Left(MyName, Len(MyName) - 4)

            For G = 1 To Sheets.Count

                k = k + 1

                If k = 1 Then '如果第一次复制,被复制文件就进行复制前面几行标题栏


                    Wb.Sheets(G).UsedRange.Copy .Cells(.Range("B" & Rows.Count).End(xlUp).Row, 2) '1是从第一列开始黏贴

                    If .Range("B" & Rows.Count).End(xlUp).Row > 100000 Then

                    MsgBox "如下表格错误,超过一万行" & Chr(13) & Wb.Name

                    End If

                    ii = .Range("B" & Rows.Count).End(xlUp).Row

                Else '否则就下移三行(假设标题栏三行) .下行代码中的Offset(3) 就是下移三行再复制,所以要下移几行改这个3为几就可以了


                    Wb.Sheets(G).UsedRange.Offset(1).Copy .Cells(.Range("B" & Rows.Count).End(xlUp).Row + 1, 2) '+1是从有数行的下一行开始黏贴

                    If .Range("B" & Rows.Count).End(xlUp).Row > (ii + 100000) Then

                    MsgBox "如下表格错误,超过一万行" & Chr(13) & Wb.Name

                    End If

                    ii = .Range("B" & Rows.Count).End(xlUp).Row


                End If

            Next

            WbN = WbN & Chr(13) & Wb.Name

            Wb.Close False

        End With

    End If

    MyName = Dir

Loop

Range("B1").Select

Application.ScreenUpdating = True

MsgBox "共合并了" & Num & "个工作薄下的全部工作表。如下:" & Chr(13) & WbN, vbInformation, "提示"

End Sub


本文链接: http://www.dtmao.cc/news_show_650136.shtml

附件下载

相关教程

    暂无相关的数据...

共有条评论 网友评论

验证码: 看不清楚?