1. 拆分单元格赋值
Sub 拆分填充() Dim x As Range
For Each x In ActiveSheet.UsedRange.Cells If x.MergeCells Then x.Select x.UnMerge
Selection.Value = x.Value End If Next x End Sub
2. Excel 宏 按列拆分多个excel
Sub Macro1()
Dim wb As Workbook, arr, rng As Range, d As Object, k, t, sh As Worksheet, i& Set rng = Range(\
Application.ScreenUpdating = False Application.DisplayAlerts = False
arr = Range(\ Set d = CreateObject(\ For i = 2 To UBound(arr)
If Not d.Exists(arr(i, 1)) Then
Set d(arr(i, 1)) = Cells(i, 1).Resize(1, 13) Else
Set d(arr(i, 1)) = Union(d(arr(i, 1)), Cells(i, 1).Resize(1, 13)) End If Next
k = d.Keys t = d.Items
For i = 0 To d.Count - 1
Set wb = Workbooks.Add(xlWBATWorksheet) With wb.Sheets(1) rng.Copy .[A1] t(i).Copy .[A2] End With
wb.SaveAs Filename:=ThisWorkbook.Path & \ wb.Close Next
Application.DisplayAlerts = True Application.ScreenUpdating = True MsgBox \完毕\End Sub
3. Excel 宏 按列拆分多个sheet
在一个工作表中是许多的公司订单记录，如何将它按公司名分拆成一个个工作表，用VBA实现相当便捷。以下是演试： 原始工作簿：
运行VBA代码后的工作簿：
代码如下： 1. 需要先把数据按照分拆的那一列字段排序 2.
如果你想应用在你的表格中，只需将所有resize(1,3)中的3修改，改成你的表格的列
数。如果你总表有8列就改成resize(1,8)即可 3. 如果你想根据表格的第一列拆分，需要把Sheet1.Cells(i, 2) <> Sheet1.Cells(i - 1, 2)和
sh.Name = Sheet1.Cells(i, 2)的2换成1 Sub s()
Application.ScreenUpdating = False Dim sh As Worksheet, i As Integer
For i = 2 To Sheet1.[a65536].End(3).Row
If Sheet1.Cells(i, 2) <> Sheet1.Cells(i - 1, 2) Then Worksheets.Add after:=Worksheets(Sheets.Count) Set sh = ActiveSheet
sh.Name = Sheet1.Cells(i, 2)
sh.Range(\Resize(1, 3).Value = Sheet1.Range(\Resize(1, 3).Value
sh.Range(\0).Resize(1, 3).Value = Sheet1.Cells(i, 1).Resize(1, 3).Value Else
sh.Range(\0).Resize(1, 3).Value = Sheet1.Cells(i, 1).Resize(1, 3).Value End If Next i
Application.ScreenUpdating = True End Sub
4.Excel 宏 多工作表合并
Function LastRow(sh As Worksheet) On Error Resume Next
LastRow = sh.Cells.Find(what:=\
After:=sh.Range(\ Lookat:=xlPart, _
LookIn:=xlFormulas, _ SearchOrder:=xlByRows, _ SearchDirection:=xlPrevious, _ MatchCase:=False).Row On Error GoTo 0 End Function Sub s()
Dim sh As Worksheet Dim DestSh As Worksheet Dim Last As Long Dim shLast As Long Dim CopyRng As Range Dim StartRow As Long
Application.ScreenUpdating = False Application.EnableEvents = False
'新建一个“汇总”工作表
Application.DisplayAlerts = False On Error Resume Next
ActiveWorkbook.Worksheets(\汇总\ On Error GoTo 0
Application.DisplayAlerts = True
Set DestSh = ActiveWorkbook.Worksheets.Add DestSh.Name = \汇总\
'开始复制的行号，忽略表头，无表头请设置成1 StartRow = 2
For Each sh In ActiveWorkbook.Worksheets
If sh.Name <> DestSh.Name Then Last = LastRow(DestSh) shLast = LastRow(sh)
If shLast > 0 And shLast >= StartRow Then
Set CopyRng = sh.Range(sh.Rows(StartRow), sh.Rows(shLast))
If Last + CopyRng.Rows.Count > DestSh.Rows.Count Then MsgBox \内容太多放不下啦！\ GoTo ExitSub End If
CopyRng.Copy
With DestSh.Cells(Last + 1, \ .PasteSpecial xlPasteValues .PasteSpecial xlPasteFormats
Application.CutCopyMode = False End With End If End If Next
ExitSub:
Application.Goto DestSh.Cells(1) DestSh.Columns.AutoFit
Application.ScreenUpdating = True Application.EnableEvents = True End Sub
excel常用宏
