excel常用宏

1.拆分单元格赋值

Sub 拆分填充()

Dim x As Range

For Each x In edRange.Cells

If x.MergeCells Then

x.Select

x.UnMerge

Selection.Value = x.Value

End If

Next x

End Sub

2.E xcel 宏按列拆分多个excel

Sub Macro1()

Dim wb As Workbook, arr, rng As Range, d As Object, k, t, sh As Worksheet, i& Set rng = Range("A1:f1")

Application.ScreenUpdating = False

Application.DisplayAlerts = False

arr = Range("a1:a" & Range("b" & Cells.Rows.Count).End(xlUp).Row)

Set d = CreateObject("scripting.dictionary")

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 & "\" & k(i) & ".xlsx"

wb.Close

Next

Application.DisplayAlerts = True

Application.ScreenUpdating = True

MsgBox "完毕"

End Sub

3.E xcel 宏按列拆分多个sheet

在一个工作表中是许多的公司订单记录，如何将它按公司名分拆成一个个工作表，用VBA 实现相当便捷。以下是演试：

原始工作簿：

运行VBA代码后的工作簿：

代码如下：

1.需要先把数据按照分拆的那一列字段排序

2.如果你想应用在你的表格中，只需将所有resize(1,3)中的3修改，改成你的表格的列

数。如果你总表有8列就改成resize(1,8)即可

3.如果你想根据表格的第一列拆分，需要把Sheet1.Cells(i, 2) <> Sheet1.Cells(i - 1, 2)和

= 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

= Sheet1.Cells(i, 2)

sh.Range("a1").Resize(1, 3).Value = Sheet1.Range("a1").Resize(1, 3).Value

sh.Range("a65536").End(3).Offset(1, 0).Resize(1, 3).Value = Sheet1.Cells(i, 1).Resize(1, 3).Value

Else

sh.Range("a65536").End(3).Offset(1, 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("A1"), _

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("汇总").Delete

On Error GoTo 0

Application.DisplayAlerts = True

Set DestSh = ActiveWorkbook.Worksheets.Add

= "汇总"

'开始复制的行号，忽略表头，无表头请设置成1

StartRow = 2

For Each sh In ActiveWorkbook.Worksheets

If <> Then

Last = LastRow(DestSh)

shLast = LastRow(sh)