loading
'
'见汇总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