excel、wps 使用vba实现按内容拆分工作表

这是计算机选手初学vba的现场。

文章目录

• • 操作说明
  • 注意事项
  • 代码

操作说明

将代码放入需要拆分的工作簿，并在目标工作表选中要拆分的列，

注意事项

需要先选中需要拆分的数据列，否则会报错

代码

'按内容拆分工作簿并调整格式
Dim 拆分列, rowNum, iserr%, index_col As Long
Sub 拆分工作簿()
'
' 拆分工作簿 Macro
'Dim Data, col, i As Long, j As Long, TargetCount As Long, RowCount As Long ', WBName%Dim ActiveWB As String, PathStr As String, arrApplication.ScreenUpdating = FalseApplication.DisplayAlerts = FalseCall 拆分列_不重复值   '获取列的不重复值-返回数组：拆分列If iserr = 1 Then iserr = 0: Exit Sub '取消退出ActiveWB = ActiveWorkbook.NameCall 获取文件夹路径(PathStr)  '获取文件夹的存储路径'WBName = Application.InputBox("请输入文件名后缀：", "操作提示！", "2023年7月销售统计", , , , , 2) '报错：类型不匹配'If WBName = False Then iserr = 1: Exit Sub  '如果点击了取消按钮，则退出过程。On Error Resume Next '后续出错，程序不中断Data = Range("A1").CurrentRegion.Value  '待拆分数据写入数组datacol = Range("A1:" & Replace(Cells(1, UBound(Data, 2)).Address(False, False), "1", "") & rowNum).Value  '数据标题行写入数组dataReDim arr(1 To UBound(col, 2), 1 To 1)For i = 0 To UBound(拆分列)TargetCount = 0For RowCount = 2 To UBound(Data)If CStr(Data(RowCount, index_col)) = 拆分列(i) ThenTargetCount = TargetCount + 1ReDim Preserve arr(1 To UBound(col, 2), 1 To TargetCount)For j = 1 To UBound(col, 2)arr(j, TargetCount) = Data(RowCount, j)NextEnd IfNextIf TargetCount > 0 ThenWorkbooks.AddWith ActiveWorkbookWith .Sheets(1).Name = 拆分列(i) & "7月发货明细".Range("A1:" & Replace(Cells(1, UBound(Data, 2)).Address(False, False), "1", "") & rowNum) = col.Range("a" & (rowNum + 1)).Resize(TargetCount, UBound(col, 2)) = WorksheetFunction.Transpose(arr)Workbooks(ActiveWB).Activate              '复制原数据表的格式Sheets(1).UsedRange.SelectSelection.Copy.Activate                                 '粘贴原数据表的格式.UsedRange.SelectSelection.PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, SkipBlanks:=False, Transpose:=FalseCall 调整格式End With.SaveAs Filename:=PathStr & 拆分列(i) & "-2023年7月销售统计" & IIf(Application.Version * 1 < 12, ".xls", ".xlsx"), FileFormat:=xlWorkbookDefault, CreateBackup:=False.CloseEnd WithErase arrWorkbooks(ActiveWB).ActivateEnd IfNextApplication.DisplayAlerts = TrueApplication.ScreenUpdating = TrueMsgBox "已拆分完成" & VBA.Chr(10) & "共拆分为：" & UBound(拆分列) + 1 & " 个工作簿！", vbInformation, "操作提示！"
End SubPrivate Sub 拆分列_不重复值() ' 返回去重后的数组Dim myRng As Range, arr1, i As Long, d1, n%If Intersect(ActiveWindow.RangeSelection, ActiveSheet.UsedRange) Is Nothing Then MsgBox "未选择，做为拆分依据的列！", vbQuestion, "提示": iserr = 1: Exit SubSet myRng = Intersect(ActiveWindow.RangeSelection, ActiveSheet.UsedRange)index_col = myRng.Columnn = Application.InputBox("请输入标题行数，标题行不参与拆分：", "操作提示！", 1, , , , , 1)  '注意n 不需要设置数据类型，数据类型已在参数里最后一位数字设置好了。If n = False Then iserr = 1: Exit Sub  '如果点击了取消按钮，则退出过程。arr1 = myRngSet d1 = CreateObject("Scripting.Dictionary")For i = 1 + n To myRng.Countd1(Trim(arr1(i, 1))) = ""  '关键字写入字典，去重（一个key对应唯一item，item可重复）Next拆分列 = d1.KeysrowNum = n
End SubPrivate Sub 获取文件夹路径(PathStr As String)With Application.FileDialog(msoFileDialogFolderPicker)If .Show ThenPathStr = .SelectedItems(1)ElseExit SubEnd IfEnd WithPathStr = PathStr & IIf(Right(PathStr, 1) = "\", "", "\")
End SubPrivate Sub 调整格式()
'
' 调整格式 Macro
'Range("A1:N1").Merge Across:=True '第一行合并并居中With Range("A1:N155").IndentLevel = 0  '缩进值.WrapText = True '自动换行End WithWith Range("A1:N1").Font.Name = "Microsoft YaHei".Size = 16.Bold = True '加粗End WithWith Range("A2:N2").Font.Name = "Microsoft YaHei".Size = 11.Bold = TrueEnd WithWith Range("A3:N155").Font.Name = "Microsoft YaHei".Size = 10End WithWith Range("A1:N155").VerticalAlignment = xlVAlignCenter.HorizontalAlignment = xlHAlignCenterEnd WithWith Range("B3:F155").HorizontalAlignment = xlHAlignLeftEnd WithWith Range("M3:M155").HorizontalAlignment = xlHAlignLeftEnd WithRange("A1:N1").RowHeight = 24.5Selection.RowHeight = 18.5'设置自动列宽Selection.EntireColumn.AutoFitSelection.EntireRow.AutoFit
End Sub

本文来自互联网用户投稿，文章观点仅代表作者本人，不代表本站立场，不承担相关法律责任。如若转载，请注明出处。 如若内容造成侵权/违法违规/事实不符，请点击【内容举报】进行投诉反馈！