批量将工作表转换为独立工作簿
Sub Newbooks（)
    'EH技术论坛.VBA编程学习与实践。看见星光
    Dim sht As Worksheet, strPath＄
    With Application.FileDialog（msoFileDialogFolderPicker)
  ’选择保存工作薄的文件路径
        If 。Show Then
            strPath = 。SelectedItems(1)
            ’读取选择的文件路径
        Else
            Exit Sub
            '如果没有选择保存路径，则退出程序
        End If
    End With
    If Right（strPath, 1) <〉 ”\” Then strPath = strPath ＆ "\"
    Application。DisplayAlerts = False
    '取消显示系统警告和消息，避免重名工作簿无法保存.当有重名工作簿时，会直接覆盖保存。
    Application。ScreenUpdating = False
    ’取消屏幕刷新
    For Each sht In Worksheets
    ’遍历工作表
        sht.Copy
        '复制工作表,工作表单纯复制后，会成为活动工作薄
        With ActiveWorkbook
            。SaveAs strPath ＆ sht。Name, xlWorkbookDefault
            '保存活动工作薄到指定路径下,以默认文件格式
            。Close True ’关闭工作薄并保存
        End With
    Next
    Application。ScreenUpdating = True ’恢复屏幕刷新
    Application。DisplayAlerts = True ’恢复显示系统警告和消息
    MsgBox ”处理完成。”, ， "提醒"
End Sub
一键将总表数据拆分为多个分表
Sub NewShts（)
    Dim d As Object, sht As Worksheet， arr, brr, r, kr, i&, j&， k&， x＆
    Dim Rng As Range, Rg As Range, tRow&， tCol＆， aCol＆, pd＆
    Application.ScreenUpdating = False ’关闭屏幕更新
    Application。DisplayAlerts = False ’关闭警告信息提示
    Set d = CreateObject（”scripting。dictionary”) 'set字典
    Set Rg = Application。InputBox（"请框选拆分依据列！只能选择单列单元格区域!”, Title:=”提示”, Type:=8)
    '用户选择的拆分依据列
    tCol = Rg。Column '取拆分依据列列标
    tRow = Val(Application。InputBox(”请输入总表标题行的行数?"))
    '用户设置总表的标题行数
    If tRow = 0 Then MsgBox "你未输入标题行行数，程序退出。”: Exit Sub
    Set Rng = ActiveSheet.UsedRange '总表的数据区域
    arr = Rng ’数据范围装入数组arr
    tCol = tCol - Rng.Column + 1 '计算依据列在数组中的位置
    aCol = UBound（arr, 2） ’数据源的列数
    For i = tRow + 1 To UBound(arr） ’遍历数组arr
        If Not d。exists(arr(i, tCol）） Then
            d(arr（i， tCol)) = i '字典中不存在关键词则将行号装入字典
        Else
            d（arr（i, tCol）) = d（arr(i, tCol)） ＆ ”,” & i ’如果存在则合并行号，以逗号间隔
        End If
    Next
    For Each sht In Worksheets '遍历一遍工作表,如果字典中存在则删除
        ists(sht。Name) Then sht。Delete
    Next
    kr = d.keys ’字典的key集
    For i = 0 To UBound(kr) ’遍历字典key值
        If kr（i） 〈〉 ”" Then '如果key不为空
            r = Split(d（kr(i)), ”,") ’取出item里储存的行号
            ReDim brr(1 To UBound（r) + 1, 1 To aCol) '声明放置结果的数组brr
            k = 0
            For x = 0 To UBound（r)
                k = k + 1 '累加记录行数
                For j = 1 To aCol ’循环读取列
                    brr(k, j） = arr（r(x）, j）
                Next
            Next
            With Worksheets。Add（, Sheets(Sheets。Count））
            '新建一个工作表,位置在所有已存在sheet的后面
                。Name = kr(i) ’表格命名
                .［a1]。Resize（tRow， aCol) = arr ’放标题行
                .［a1].Offset（tRow, 0).Resize（k, aCol) = brr ’放置数据区域
                Rng.Copy ’复制粘贴总表的格式
                。［a1］.PasteSpecial Paste:=xlPasteFormats, Operation：=xlNone， SkipBlanks：=False, Transpose：=False
                .［a1］。Select
            End With
        End If
    Next
    Sheets(1）。Activate ’激活第一个表格
    Set d = Nothing ’释放字典
    Erase arr: Erase brr '释放数组
    MsgBox "数据拆分完成！”
    Application。ScreenUpdating = True ’恢复屏幕更新
    Application.DisplayAlerts = True '恢复警示
End Sub
一键汇总各分表数据到总表
Sub collect（）
    'VBA编程学习与实践，一键多表数据汇总
    Dim sht As Worksheet, rng As Range, k&, trow＆
    Application.ScreenUpdating = False
    ’取消屏幕更新，加快代码运行速度
    trow = Val（InputBox(”请输入标题的行数”， ”提醒”）)
    If trow 〈 0 Then MsgBox "标题行数不能为负数。", 64, "警告"： Exit Sub
    ’取得用户输入的标题行数，如果为负数,退出程序
    Cells。ClearContents
    ’清空当前表数据
    For Each sht In Worksheets
    '循环读取表格
        If sht。Name <〉 ActiveSheet.Name Then
        ’如果表格名称不等于当前表名则进行汇总动作……
            Set rng = sht。UsedRange
            ’定义rng为表格已用区域
            k = k + 1
            ’累计K值
            If k = 1 Then
            '如果是首个表格，则K为1，则把标题行一起复制到汇总表
                rng。Copy
                [a1］。PasteSpecial Paste：=xlPasteValues
            Else
                '否则，扣除标题行后再复制黏贴到总表，只黏贴数值
                rng。Offset（trow）.Copy
                Cells（ActiveSheet.UsedRange.Rows.Count + 1, 1).PasteSpecial Paste:=xlPasteValues
            End If
        End If
    Next
    ［a1]。Activate
    '激活A1单元格
    Application.ScreenUpdating = True
    ’恢复屏幕刷新
End Sub
汇总多个工作簿的数据到总表？没问题！
Sub CollectWorkBookDatas()
    Dim ShtActive As Worksheet， rngData As Range, ShtData As Worksheet
    Dim lngHeadLine As Long， k As Long
    Dim i As Long, j As Long, n As Long
    Dim aData, aResult
    Dim strPath As String， strFileName As String
    Dim strKey As String， lngShtCount As Long， lngTemp As Long
    On Error Resume Next
    With Application。FileDialog(msoFileDialogFolderPicker）
    '取得用户选择的文件夹路径
        If .Show Then strPath = 。SelectedItems（1) Else Exit Sub
    End With
    If Right（strPath, 1) <> "\” Then strPath = strPath ＆ ”\"
    strKey = InputBox（"请输入需要合并的工作名称表包含的关键字: ", ”Reminder”）
    If StrPtr(strKey) = 0 Then Exit Sub
    ’如果点击了取消或者关闭按钮，则退出程序
    lngHeadLine = Val（InputBox(”Please input the header line quantity", "Reminder”, 1）)
    ’用户输入标题行，默认值为1
    If lngHeadLine 〈 0 Then MsgBox "请输入标题行的行数。 ", 64, "my user": Exit Sub
    Set ShtActive = ActiveSheet
    With Application
        .ScreenUpdating = False
        .DisplayAlerts = False
        。AskToUpdateLinks = False
    End With
    Const DATA_MAXROW As Long = 50000 ’结果数组最大行数
    Const WK_SHT_NAME As Long = 2 ’前面两列是工作簿和工作表名称的标题
    ReDim aResult（1 To DATA_MAXROW, -1 To 1） ’声明结果数组
    Cells。Clear ’清除原表内容
    strFileName = Dir(strPath ＆ "＊。xlsx＊")
    ’使用Dir函数遍历excel文件
    Do While strFileName <> "”
resize函数vba
        If strFileName <> ThisWorkbook。Name Then '避免同名文件重复打开出错
            With GetObject(strPath & strFileName）
            ’以只读'形式读取文件时，使用getobject会比workbooks。open稍快
                For Each ShtData In 。Worksheets '遍历表
                    If InStr（1, ShtData.Name， strKey， vbTextCompare) Then
                    '如果表中包含关键字则进行汇总(不区分关键词字母大小写）
                        Set rngData = ShtData.UsedRange
                        If IsEmpty(rngData) = False Then
                        ’如果工作表非空……
                            lngShtCount = lngShtCount + 1 ’标记一下汇总工作表的个数
                            aData = rngData。Value ’数据区域读入数组aData
                            If UBound（aData, 2) 〉 UBound（aResult， 2） Then
                            '动态调整结果数组aResult的最大列数，避免明细表列数不一的情况。
                                For j = UBound（aResult, 2) To UBound（aData， 2）
                                ’将新增的标题写入汇总表
                                    For i = 1 To lngHeadLine
                                        ShtActive。Cells(i， j + WK_SHT_NAME）。Value = aData(i, j）
                                    Next
                                Next
                                ReDim Preserve aResult(1 To DATA_MAXROW， —1 To UBound（aData, 2)）
                            End If
                            For i = lngHeadLine + 1 To UBound（aData） '遍历数据区域的行
                                lngTemp = 0
                                For j = 1 To UBound（aData, 2) ’遍历列
                                    If Len（aData（i， j)） = 0 Then lngTemp = lngTemp + 1
                                    ’判断是否为空值
                                Next
                                If lngTemp 〈> UBound(aData, 2） Then ’如果整行非空则读入结果数组
                                    k = k + 1 '累加记录条数
                                    aResult（k, —1) = strFileName '工作簿名称
                                    aResult(k, 0） = ShtData。Name '工作表名称
                                    For j = 1 To UBound（aData, 2）
                                        aResult（k, j) = "’” & aData（i, j)  '全部转换为文本,避免数值变形
                                    Next
                                End If
                                If k = DATA_MAXROW Then
                                '如果数据到达结果数组的上限，则读入表格，腾出空间，以便装新的数据
                                    ShtActive.Range（”a1"）。Offset（lngHeadLine + n).Resize（k， UBound（aResult， 2） + WK_SHT_NAME) = aResult
                                    n = n + DATA_MAXROW
                                    ReDim aResult（1 To DATA_MAXROW， -1 To UBound(aResult， 2)）
                                    k = 0
                                End If
                            Next
                        End If
                    End If
                Next
                。Close False '关闭工作簿
            End With
        End If
        strFileName = Dir ’下一个excel文件
    Loop
    ShtActive。Range(”a1：b1"） = Array（”File name”， "Sheet name”)
    If k 〉 0 Then
        ShtActive.Range(”a1").Offset(lngHeadLine + n)。Resize（k, UBound（aResult， 2） + WK_SHT_NAME) = aResult
        MsgBox "Summary done， total combined： ” & lngShtCount & ”sheets", , ”Thank you”
    End If
    With Application
        .ScreenUpdating = True
        .DisplayAlerts = True
        。AskToUpdateLinks = True
    End With
End Sub
VBA常用代码：按一列中的部门拆分成工作簿
Sub NewWorkBooks()
    Dim d As Object, arr， brr， r， kr， i＆， j＆, k＆, x＆, Mystr$
    Dim Rng As Range， Rg As Range， tRow＆, tCol＆， aCol&， pd&， mypath＄
    Dim Cll As Range, sht As Worksheet
    ' '
    ’第一部分,用户选择保存分表工作簿的路径。
    With Application.FileDialog(msoFileDialogFolderPicker)
   ’选择保存工作薄的文件路径
        。AllowMultiSelect = False
        '不允许多选
        If 。Show Then
            mypath = .SelectedItems（1)
            '读取选择的文件路径
        Else
            Exit Sub
            '如果没有选择保存路径，则退出程序
        End If
    End With
    If Right（mypath, 1） <> ”\" Then mypath = mypath & ”\"
    ’   ’
    ’第二部分遍历总表数据，通过字典将指定字段的不同明细行过滤保存
    Set d = CreateObject（”scripting。dictionary”） 'set字典
    Set Rg = Application.InputBox（"请框选拆分依据列！只能选择单列单元格区域！”, Title：="提示”， Type:=8）
    ’用户选择的拆分依据列
    tCol = Rg。Column '取拆分依据列列标

版权声明：本站内容均来自互联网，仅供演示用，请勿用于商业和其他非法用途。如果侵犯了您的权益请与我们联系QQ:729038198，我们将在24小时内删除。