Excel自编宏大全（Word版）

'

'见汇总0204.xls ' 2007-2-4 '蓝桥玄霜 '大汇总问题 '

Dim x As Integer, y As Integer Dim rng1 As Range, tbl As Range Dim n As Integer

Dim Myrow1 As Integer, Myrow2 As Integer

Dim rng2

Application.ScreenUpdating = False

Sheets(\汇总\ '清除总表原有的数据 Range(\

Set tbl = ActiveCell.CurrentRegion If tbl.Rows.Count > 1 Then

tbl.Offset(1, 0).Resize(tbl.Rows.Count - 1, tbl.Columns.Count).ClearContents Else End If n = 2

Sheets(\使用型号表\ Range(\

Myrow1=[a65536].End(xlUp).Row 'A列最下面一行的行数，中间有空格也行 For x = 2 To Myrow1

Sheets(\使用型号表\

Set rng1 = Range(\ '依次把“使用数量”的值赋给rng1变量 rng2 = Range(\ '把序号里的表格名赋给rng2变量 If rng1.Value <> \

Sheets(\汇总\alue Sheets(rng2).Select '用表格名选择表格 Range(\

Myrow2 = Selection.CurrentRegion.Rows.Count '数据的行数 Range(Cells(2, 2), Cells(Myrow2, 5)).Copy '复制这些数据 Sheets(\汇总\

Cells(n, 2).PasteSpecial '粘贴到汇总表

Range(Cells(n, 6), Cells(Myrow2 + n - 2, 6)).Select '选择F列相同行数 Selection.FormulaR1C1 = \ '将使用数量X数量 Range(Cells(n, 6), Cells(Myrow2 + n - 2, 6)).Copy '复制这些数据 Cells(n, 5).Select

Selection.PasteSpecial Paste:=xlValues

'以“选择性粘贴”的“数值”粘贴

Range(Cells(n, 6), Cells(Myrow2 + n - 2, 6)).ClearContents '清除F列数量 Cells(1, 6).ClearContents

n = n + Myrow2 - 1 '为下次粘贴数据的行位置 Else End If Next x

bcfhz0204 '不重复汇总的宏

Application.ScreenUpdating = True End Sub

Sub bcfhz0204() '不重复汇总 '蓝桥玄霜 '2007-2-4

Dim b As Integer, x As Integer, y As Integer, aa As Integer, yyy As Integer Dim minc As Range

Dim rng1 As Range, a As Range

Dim n1 As Integer, nn As Integer, Myrow1 As Integer Dim pp, pp1

On Error Resume Next Sheets(\汇总\ Range(\

Myrow1 = Selection.CurrentRegion.Rows.Count 'A列数据的行数 Set minc = Range(\ Set rng1 = Range(\

Range(\ '求重复值个数的辅助列公式 Selection.Formula = \ Selection.AutoFill Destination:=rng1, Type:=xlFillDefault '公式往下复制 b = Application.WorksheetFunction.Max(rng1)

Range(\ '求重复值的辅助列公式 Selection.Formula = \$65536,0)))\

Selection.AutoFill Destination:=Range(\ '公式往下复制

Range(\

'以“选择性粘贴”的“数值”粘贴n,m列，因为删除一行后，公式会重新计算 ' Selection.Copy Range(\

Selection.PasteSpecial Paste:=xlValues

rng1.Select Selection.Copy Range(\

Selection.PasteSpecial Paste:=xlValues For x = 2 To b + 1

Set a = Range(\

aa = Application.WorksheetFunction.CountIf(minc, a) '计算重复值的个数 Range(\ nn = aa

Range(\

Range(\ '重复值所在行数的数组公式 Selection.FormulaArray = \$1,row(minc),\

Selection.AutoFill Destination:=Range(\ Range(\ Selection.Copy Range(\

Selection.PasteSpecial Paste:=xlValues

'以“选择性粘贴”的“数值”粘贴去除公式影响 For y = 2 To nn '在重复值里循环比较

pp = Range(\ '将行数赋给变量pp For yy = y + 1 To nn + 1

pp1 = Range(\ '将行数赋给变量pp1 If pp1 = \ GoTo 100 Else End If

If Cells(pp, 2) = Cells(pp1, 2) And Cells(pp, 3) = Cells(pp1, 3) And Cells(pp, 4) = Cells(pp1, 4) Then

Cells(pp, 5) = Cells(pp, 5) + Cells(pp1, 5) '汇总部分 Range(Cells(pp1, 1), Cells(pp1, 5)).Delete shift:=xlUp '删除多余的行

For yyy = yy + 1 To nn + 1

Range(\ Next yyy

Range(\ yy = yy - 1: nn = nn - 1 Else End If Next yy 100: Next y nn = aa

Range(\ '清除辅助列数据

200: Next x

Range(\

Selection.CurrentRegion.ClearContents '清除辅助列数据 Range(\ '以下在A列加上序号 n1 = Selection.CurrentRegion.Rows.Count Range(\

ActiveCell.FormulaR1C1 = \ Range(\

ActiveCell.FormulaR1C1 = \ Range(\

Selection.AutoFill Destination:=Range(\ Range(\

End Sub

4，工作表的名称和index号

Sub Sheetsname() ?见上例的xls ?2007-2-2

Dim Sht As Worksheet

Sheets(\使用型号表\n = 2

For Each Sht In ActiveWorkbook.Worksheets

If Sht.Name <> \汇总\使用型号表\ ActiveSheet.Range(\ ActiveSheet.Range(\

n = n + 1 Else End If Next Sht End Sub

5，重复值加色

Sub 重复值加色() '重复值加色.xls