Excel自编宏大全(Word版)

1、目录1，从数据源匹配取数的问题2，部分字符地址查找3，多表查询汇总和重复值问题（相同行删除、循环比较）4，工作表的名称和index号5，重复值加色6，统计7，最大或最小8，最后一记录（定义动态区域名称、不重复值公式宏、不重复值个数和行数公式宏、加边框宏）9，大港表格转换10，筛选尾数11，对比数据12，修改批注字体13，删除合并单元格14，物品领用报表15，条件格式设置16，多表查询，自动筛选法17，多条件查询累计汇总18，和值19，教师安排汇总（循环比较、不重复值）20，自动着色（不同个数、不同颜色）21，不重复值的个数及所在行的行数（各个值的个数、行数）22，分表自动字体格式化23，自动填

2、充数字24，导入文本文件25，累计不变化（内部循环）26，同结构多表统计汇总（Consolidate方法）27，资产负债表汇总（多工作簿汇总）28，导出到文本文件29，角度求和的自定义公式30，表单输入模板31，两表间复制与核对1，从数据源匹配取数的问题Sub 宏131()'从数据源匹配取数的问题131.xls' 2007-1-31' Shizx98' Dim a As Range, Myrng1 As Range, Myrng2 As Range Dim Myrow As Integer Dim Myrow1 As Integer Dim Myrow2 As

3、Integer Dim Myrow3 As Integer Dim x As Integer Worksheets("Sheet1").Activate Range("d2").Select Selection.CurrentRegion.Select Myrow2 = Selection.Rows.Count 'D列数据的行数 Range("a1").Select Myrow3 = Selection.CurrentRegion.Rows.Count 'AB列数据的行数 Set Myrng1 = Range(Cell

4、s(2, 1), Cells(Myrow3, 1) Set Myrng2 = Range(Cells(2, 2), Cells(Myrow3, 2) For x = 2 To Myrow2 + 1 Set a = Range("D" & x) For y = 1 To Myrow3 If Len(a) > 7 Then Myrow = Application.WorksheetFunction.Match(a, Myrng1, 0) Else Myrow = Application.WorksheetFunction.Match(a, Myrng2, 0) E

5、nd If If Myrow = 0 Then GoTo 100 Else Range("F1").Select Selection.CurrentRegion.Select Myrow1 = Selection.Rows.Count Range(Cells(Myrow + 1, 1), Cells(Myrow + 1, 2).Select Selection.Cut Destination:=Range(Cells(Myrow1 + 1, 6), Cells(Myrow1 + 1, 7) Selection.Delete Shift:=xlUp Myrow = 0 Msg

6、Box "已找到！" GoTo 200 End If100: Next y200: Next xEnd Sub2，部分字符地址查找2007/1/30部分字符地址查找.xlsSub bfzfcz() Dim Myrow1 As Integer Dim Myrow2 As Integer Dim x%, y1%, y2%, gg% Dim AA, BB On Error Resume Next Range("a2").Select Selection.CurrentRegion.Select Myrow1 = Selection.Rows.Count Ran

7、ge("e1").Select Selection.CurrentRegion.Select Myrow2 = Selection.Rows.Count gg = 2 For x = 2 To Myrow2 AA = Range("e" & x) For y1 = 2 To Myrow1 + 1 BB = Application.WorksheetFunction.SearchB(AA, Cells(y1, 1) If BB > 0 Then Range("g" & gg) = "A" &am

8、p; y1 gg = gg + 1 Else End If BB = 0 Next y1 For y2 = 2 To Myrow1 + 1 BB = Application.WorksheetFunction.SearchB(AA, Cells(y2, 2) If BB > 0 Then Range("g" & gg) = "B" & y2 gg = gg + 1 Else End If BB = 0 Next y2 'gg = gg + 1 Next xEnd Sub3，多表查询汇总和重复值问题（相同行删除、循环比较）Su

9、b 宏0204()''见汇总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 IntegerDim rng2 Application.ScreenUpdating = False Sheets("汇总").Select '清除总表原有的数据 Range("a1").

10、Select 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("使用型号表").Select Range("a1").Select Myrow1=a65536.End(xlUp).Row 'A列最下面一行的行数，中间有空格也行 For x = 2 To Myrow1

11、 Sheets("使用型号表").Select Set rng1 = Range("B" & x) '依次把“使用数量”的值赋给rng1变量 rng2 = Range("A" & x).Text '把序号里的表格名赋给rng2变量 If rng1.Value <> "" Then Sheets("汇总").Cells(1, 6).Value = rng1.Value Sheets(rng2).Select '用表格名选择表格 Range(&qu

12、ot;a1").Select Myrow2 = Selection.CurrentRegion.Rows.Count '数据的行数 Range(Cells(2, 2), Cells(Myrow2, 5).Copy '复制这些数据 Sheets("汇总").Activate Cells(n, 2).PasteSpecial '粘贴到汇总表 Range(Cells(n, 6), Cells(Myrow2 + n - 2, 6).Select '选择F列相同行数 Selection.FormulaR1C1 = "=RC-1*r1

13、c6" '将使用数量X数量 Range(Cells(n, 6), Cells(Myrow2 + n - 2, 6).Copy '复制这些数据 Cells(n, 5).SelectSelection.PasteSpecial Paste:=xlValues '以“选择性粘贴”的“数值”粘贴 Range(Cells(n, 6), Cells(Myrow2 + n - 2, 6).ClearContents '清除F列数量 Cells(1, 6).ClearContents n = n + Myrow2 - 1 '为下次粘贴数据的行位置 Else E

14、nd If Next x bcfhz0204 '不重复汇总的宏 Application.ScreenUpdating = TrueEnd SubSub 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

15、Dim pp, pp1 On Error Resume Next Sheets("汇总").Select Range("a1").Select Myrow1 = Selection.CurrentRegion.Rows.Count 'A列数据的行数 Set minc = Range("b2:b" & Myrow1) Set rng1 = Range("m2:m" & Myrow1) Range("m2").Select '求重复值个数的辅助列公式 Selectio

16、n.Formula = "=if(countif(minc,$b2)>1)*(match($b2,minc,0)=row($a1),count(m$1:m1)+1,"""")" Selection.AutoFill Destination:=rng1, Type:=xlFillDefault '公式往下复制 b = Application.WorksheetFunction.Max(rng1) Range("n2").Select '求重复值的辅助列公式 Selection.Formula =

17、 "=if(iserror(index(minc,match(row(b1),m$2:m$65536,0),"""",index(minc,match(row(b1),m$2:m$65536,0)" Selection.AutoFill Destination:=Range("n2:n" & b + 1), Type:=xlFillDefault '公式往下复制Range("n2:n" & b + 1).Select'以“选择性粘贴”的“数值”粘贴n,m列，因为删

18、除一行后，公式会重新计算 ' Selection.Copy Range("n2").Select Selection.PasteSpecial Paste:=xlValues rng1.Select Selection.Copy Range("m2").Select Selection.PasteSpecial Paste:=xlValues For x = 2 To b + 1 Set a = Range("n" & x) aa = Application.WorksheetFunction.CountIf(minc

19、, a) '计算重复值的个数 Range("o" & x).Value = aa nn = aa Range("p1") = a Range("p2").Select '重复值所在行数的数组公式 Selection.FormulaArray = "=if($p$1<>"""",if(iserror(small(if(minc=$p$1,row(minc),""""),row(1:1),""&

20、quot;",small(if(minc=$p$1,row(minc),""""),row(1:1)" Selection.AutoFill Destination:=Range("p2:p" & aa + 1), Type:=xlFillDefault Range("p2:p" & aa + 1).Select Selection.Copy Range("p2").Select Selection.PasteSpecial Paste:=xlValues &

21、#39;以“选择性粘贴”的“数值”粘贴去除公式影响 For y = 2 To nn '在重复值里循环比较 pp = Range("p" & y).Value '将行数赋给变量pp For yy = y + 1 To nn + 1 pp1 = Range("p" & yy).Value '将行数赋给变量pp1 If pp1 = "" Then GoTo 100 Else End If If Cells(pp, 2) = Cells(pp1, 2) And Cells(pp, 3) = Cells(

22、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("p" & yyy) = Range("p" & yyy) - 1 Next yyy Range("p" & yy).

23、Delete shift:=xlUp yy = yy - 1: nn = nn - 1 Else End If Next yy100: Next y nn = aa Range("p1:P" & aa + 1).ClearContents '清除辅助列数据200: Next x Range("m1").Select Selection.CurrentRegion.ClearContents '清除辅助列数据 Range("A1").Select '以下在A列加上序号 n1 = Selection.Cur

24、rentRegion.Rows.Count Range("A2").Select ActiveCell.FormulaR1C1 = "1" Range("A3").Select ActiveCell.FormulaR1C1 = "2" Range("A2:A3").Select Selection.AutoFill Destination:=Range("A2:A" & n1), Type:=xlFillDefault Range("A2").Se

25、lectEnd Sub4，工作表的名称和index号Sub Sheetsname()见上例的xls2007-2-2Dim Sht As WorksheetSheets("使用型号表").Activaten = 2For Each Sht In ActiveWorkbook.Worksheets If Sht.Name <> "汇总" And Sht.Name <> "使用型号表" Then ActiveSheet.Range("k" & n) = Sht.Name ActiveShe

26、et.Range("l" & n) = Sht.Index n = n + 1 Else End IfNext ShtEnd Sub5，重复值加色Sub 重复值加色()'重复值加色.xls' 蓝桥玄霜 2007-2-2'表格中有重复值公式' Dim rng1 As Range, data As Range Dim b As Integer Set rng1 = Range("n2:n117")重复值区域 b = Application.WorksheetFunction.Max(rng1)重复值个数 Range(&

27、quot;B2:B117").Select Selection.FormatConditions.Delete For X = 2 To b + 1用查找 Selection.FormatConditions.Add Type:=xlCellValue, Operator:=xlEqual, _ Formula1:="=$M$" & X Selection.FormatConditions(X - 1).Interior.ColorIndex = 3 Next XEnd Sub6，统计Sub tongji()车次统计，见统计月报1.xlsExcel论坛 D

28、im Myrow1 As Integer, Myrow2 As Integer Dim Sht As Worksheet, Sht1 As Worksheet Application.ScreenUpdating = False On Error Resume Next For Each Sht In ActiveWorkbook.Worksheets 'AB列空格填充 If Sht.Name <> "月计" Then Sheets(Sht.Name).Select Range("a1").Select Myrow1 = a65536

29、.End(xlUp).Row 'A列最下面一行的行数，中间有空格也行 Set rng1 = Range(Cells(4, 1), Cells(Myrow1 - 1, 2) rng1.Select If IsError(Selection.SpecialCells(xlCellTypeBlanks) Then GoTo 100 Else Selection.SpecialCells(xlCellTypeBlanks).Select Range("A5").Activate Selection.FormulaR1C1 = "=R-1C" Range(

30、"A4").Select rng1.Select Selection.Copy Selection.PasteSpecial Paste:=xlValues Application.CutCopyMode = False Range("A4").Select End If Else End If100: Next Sht Sheets("月计").Select Set Sht1 = Sheets("月计") Range("a1").SelectMyrow1 = a65536.End(xlUp).

31、Row Myrow1 = Myrow1 - 1 Range(Cells(4, 4), Cells(Myrow1, 11).ClearContents For x = 4 To Myrow1 fa = Range("a" & x).Value dao = Range("b" & x).Value If fa = "" And dao = "" Then GoTo 200 Else End If For n = 1 To 10 Sheets(n).Activate Range("a1"

32、;).Select Myrow2 = a65536.End(xlUp).Row Myrow2 = Myrow2 - 1 For y = 4 To Myrow2 fa1 = Range("a" & y).Value dao1 = Range("b" & y).Value If fa = fa1 And dao = dao1 Then Sht1.Range("d" & x) = Sht1.Range("d" & x) + Range("d" & y) '

33、;汇总 Sht1.Range("e" & x) = Sht1.Range("e" & x) + Range("e" & y) Sht1.Range("f" & x) = Sht1.Range("f" & x) + Range("f" & y) Sht1.Range("g" & x) = Sht1.Range("g" & x) + Range("g" &a

34、mp; y) Sht1.Range("h" & x) = Sht1.Range("h" & x) + Range("h" & y) Sht1.Range("i" & x) = Sht1.Range("i" & x) + Range("i" & y) Sht1.Range("j" & x) = Sht1.Range("j" & x) + Range("j"

35、 & y) Sht1.Range("k" & x) = Sht1.Range("k" & x) + Range("k" & y) Else End If Next y Next n Sheets("月计").Select200: Next x Sheets("月计").SelectApplication.ScreenUpdating = TrueEnd Sub7，最大或最小Excel论坛最大或最小.xlsSub MaxMin()Dim rng1 As RangeD

36、im x As Integer, b As IntegerDim a(12)Range("a14").Value = ""For x = 1 To 12Cells(2, x + 3).SelectSet rng1 = Cells(2, x + 3)a(x) = Selection.Valueb = Application.WorksheetFunction.Find("/", rng1)a(x) = Left(rng1, b)a(x) = Val(a(x)Next xMymax = Application.WorksheetFunct

37、ion.Max(a(1), a(2), a(3), a(4), a(5), a(6), a(7), a(8), a(9), a(10), a(11), a(12)Mymin = Application.WorksheetFunction.Min(a(1), a(2), a(3), a(4), a(5), a(6), a(7), a(8), a(9), a(10), a(11), a(12)If a(1) = Mymax Then Range("a14").FormulaR1C1 = "最大"Else If a(1) = Mymin Then Range(

38、"a14").FormulaR1C1 = "最小" Else End IfEnd IfEnd Sub8，最后一记录（定义名称）Sub zhytjl0206()'最后一次的那条记录.xls'Shizx98'2007-2-6 Dim b As Integer, x As Integer, y As Integer, aa As Integer Dim minc As Range Dim rng1 As Range, a As Range Dim nn As Integer, Myrow1 As Integer Dim pp, pp1

39、Dim Sht1 As Worksheet, Sht2 As Worksheet On Error Resume Next Application.ScreenUpdating = False Set Sht1 = Sheets(1): Set Sht2 = Sheets(3) Sht1.Activate ActiveWorkbook.Names.Add Name:="data1", RefersToR1C1:= _ "=OFFSET(Sheet1!R1C1,1,COUNTA(Sheet1!R2C1:R65535C1),)" Range("n1

40、").Select Selection.CurrentRegion.ClearContents '清除辅助列数据 Sheet2.Activate Range("a1").Select Selection.CurrentRegion.ClearContents '清除上次数据 Sht1.Range("a1:g1").Copy Sheet2.a1 Sht1.Activate Range("a1").Select Myrow1 = Selection.CurrentRegion.Rows.Count 'A列

41、数据的行数 Set minc = Range("a2:a" & Myrow1) Set rng1 = Range("n2:n" & Myrow1) BcfzGS '转求不重复值宏 For x = 2 To b + 1 FuzulieGS '转辅助列公式宏 Range("p2:p" & aa + 1).Select Selection.Copy Sht2.Range("a2") Application.CutCopyMode = False Sht1.Activate pp =

42、 Sht1.Range("p" & 2).Value '将行数赋给变量pp Range(Cells(pp, 7), Cells(pp + aa - 1, 7).Select Selection.Copy Sht2.Range("b2") '时间复制到表2 Sht2.Activate Cells(2, 3).Select Selection.Formula = "=datevalue(rc-1)+timevalue(rc-1)" '时间值公式 If aa > 1 Then Selection.Aut

43、oFill Destination:=Range("c2:c" & aa + 1), Type:=xlFillDefault '公式往下复制 Range("a2:c" & aa + 1).Select Selection.Sort Key1:=Range("C2"), Order1:=xlDescending, Header:=xlNo, _ OrderCustom:=2, MatchCase:=False, Orientation:=xlTopToBottom, SortMethod _ :=xlPinYin

44、 Else End If pp1 = Range("a2").Value Sheets(2).Select For xx = 1 To 7 Cells(x, xx) = Sht1.Cells(pp1, xx) Next xx nn = aa Sht1.Activate Range("p1:P" & aa + 1).ClearContents '清除辅助列数据 Sht2.Activate Range(Cells(1, 1), Cells(aa + 1, 3).ClearContents200: Next x Sht1.Activate Ra

45、nge("m1").Select Selection.CurrentRegion.ClearContents '清除辅助列数据 Sheets(2).Activate Range("a1:g" & b + 1).Select 排序 Selection.Sort Key1:=Range("a1"), Order1:=xlAscending, Header:=xlGuess, _ OrderCustom:=2, MatchCase:=False, Orientation:=xlTopToBottom, SortMethod

46、_ :=xlPinYin加边框 '转加边框宏 Range("A1").Select Application.ScreenUpdating = TrueEnd SubSub BcfzGS()'不重复值公式 Range("n2").Select '辅助列公式求有几个不重复值 Selection.FormulaArray = "=index(a:a,min(if(countif(n$1:n1,data1),65536,row(data1)&""""" Selection

47、.AutoFill Destination:=rng1, Type:=xlFillDefault '公式往下复制 b = Application.WorksheetFunction.CountIf(rng1, "4*")End SubSub FuzulieGS()'某个不重复值的个数和所在行数的数组公式 Sht1.Select Set a = Range("n" & x) aa = Application.WorksheetFunction.CountIf(minc, a) '计算某个不重复值的个数 Range("

48、;o" & x).Value = aa nn = aa Range("p1") = Val(a) Range("p2").Select '某个不重复值所在行数的数组公式 Selection.FormulaArray = "=if($p$1<>"""",if(iserror(small(if(minc=$p$1,row(minc),""""),row(1:1),"""",small(if(m

49、inc=$p$1,row(minc),""""),row(1:1)" If aa > 1 Then Selection.AutoFill Destination:=Range("p2:p" & aa + 1), Type:=xlFillDefault Else End IfEnd SubSub 加边框() BorderVars(1) = xlEdgeLeft BorderVars(2) = xlEdgeTop BorderVars(3) = xlEdgeBottom BorderVars(4) = xlEdge

50、Right BorderVars(5) = xlInsideVertical BorderVars(6) = xlInsideHorizontal Range("a1:g" & b + 1).Select Selection.Borders(xlDiagonalDown).LineStyle = xlNone Selection.Borders(xlDiagonalUp).LineStyle = xlNone For x = 1 To 6 With Selection.Borders(BorderVars(x) .LineStyle = xlContinuous .

51、Weight = xlThin .ColorIndex = xlAutomatic End With NextEnd SubSub zhytjl0215()'最后一条记录0215.xls'蓝桥玄霜,'2007-2-15'根据czzqbµ的数组公式修改'在表1的H列加了时间转换公式 Dim b As Integer, x As Integer, y As Integer Dim minc As Range Dim rng1 As Range, a As Range Dim Myrow1 As Integer Dim Sht1 As Workshe

52、et, Sht2 As Worksheet Dim BorderVars(6) As Variant On Error Resume Next Application.ScreenUpdating = False Set Sht1 = Sheets(1): Set Sht2 = Sheets(2) Sht1.Activate 定义动态区域名称 ActiveWorkbook.Names.Add Name:="data1", RefersToR1C1:= _ "=OFFSET(Sheet1!R1C1,1,COUNTA(Sheet1!R2C1:R65535C1),)" ActiveWorkbook.Names.Add Name:="shiji", RefersToR1C1:= _ "=OFFSET(Sheet1!R1C8,1,COUNTA(Sheet1!R2C8:R65535C8),)" Range("n1").Select Selection.CurrentRegion.ClearContents Sheet2.Activate Range("