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 Integer Dim Myrow3 A

3、s 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(Cells(2, 1), Cells(Myrow3, 1) Set Myrng2 = Range(Cells(2, 2), Cells(My

4、row3, 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) End If If Myrow = 0 Then GoTo 100 Else Range(F1).Select Selection.CurrentRegion.Select M

5、yrow1 = 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 MsgBox 已找到！ GoTo 200 End If100: Next y200: Next xEnd Sub2，部分字符地址查找2007/1/30部分字符地址查找.xlsSub bfzfcz() Di

6、m 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 Range(e1).Select Selection.CurrentRegion.Select Myrow2 = Selection.Rows.Count gg = 2 For x = 2 To Myrow2 AA = Range(e & x) For

7、 y1 = 2 To Myrow1 + 1 BB = Application.WorksheetFunction.SearchB(AA, Cells(y1, 1) If BB 0 Then Range(g & gg) = A & 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 I

8、f BB = 0 Next y2 gg = gg + 1 Next xEnd Sub3，多表查询汇总和重复值问题（相同行删除、循环比较）Sub 宏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 清除总表原有的数据

9、 Range(a1).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 Sheets(使用型号表).Select S

10、et 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(a1).Select Myrow2 = Selection.CurrentRegion.Rows.Count 数据的行数 Range(Cells(2, 2), Cells(Myrow2, 5).Copy 复制这些数据 Sheets(汇总)

11、.Activate Cells(n, 2).PasteSpecial 粘贴到汇总表 Range(Cells(n, 6), Cells(Myrow2 + n - 2, 6).Select 选择F列相同行数 Selection.FormulaR1C1 = =RC-1*r1c6 将使用数量X数量 Range(Cells(n, 6), Cells(Myrow2 + n - 2, 6).Copy 复制这些数据 Cells(n, 5).SelectSelection.PasteSpecial Paste:=xlValues 以“选择性粘贴”的“数值”粘贴 Range(Cells(n, 6), Cells(

12、Myrow2 + n - 2, 6).ClearContents 清除F列数量 Cells(1, 6).ClearContents n = n + Myrow2 - 1 为下次粘贴数据的行位置 Else End 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

13、 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(汇总).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 求重复值个数的辅助列公式 Sel

14、ection.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 = =if(iserror(index(minc,match(row(b1),m$2:m$65536,0),inde

15、x(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列，因为删除一行后，公式会重新计算 Selection.Copy Range(n2).Select Selection.PasteSpecial Paste:=xlValues rng1.Select Selection.Copy Range(m2).Select Selectio

16、n.PasteSpecial Paste:=xlValues For x = 2 To b + 1 Set a = Range(n & x) aa = Application.WorksheetFunction.CountIf(minc, 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),small(i

17、f(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 以“选择性粘贴”的“数值”粘贴去除公式影响 For y = 2 To nn 在重复值里循环比较 pp = Range(p & y).Value 将行数赋给变量pp For yy = y +

18、 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(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 删除多余的行 Fo

19、r yyy = yy + 1 To nn + 1 Range(p & yyy) = Range(p & yyy) - 1 Next yyy Range(p & yy).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

20、 以下在A列加上序号 n1 = Selection.CurrentRegion.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).SelectEnd Sub4，工作表的名称和index号Sub Sheetsname()见上例的xls2007-2-2Di

21、m Sht As WorksheetSheets(使用型号表).Activaten = 2For Each Sht In ActiveWorkbook.Worksheets If Sht.Name 汇总 And Sht.Name 使用型号表 Then ActiveSheet.Range(k & n) = Sht.Name ActiveSheet.Range(l & n) = Sht.Index n = n + 1 Else End IfNext ShtEnd Sub5，重复值加色Sub 重复值加色()重复值加色.xls 蓝桥玄霜 2007-2-2表格中有重复值公式 Dim rng1 As Ra

22、nge, data As Range Dim b As Integer Set rng1 = Range(n2:n117)重复值区域 b = Application.WorksheetFunction.Max(rng1)重复值个数 Range(B2:B117).Select Selection.FormatConditions.Delete For X = 2 To b + 1用查找 Selection.FormatConditions.Add Type:=xlCellValue, Operator:=xlEqual, _ Formula1:=$M$ & X Selection.FormatC

23、onditions(X - 1).Interior.ColorIndex = 3 Next XEnd Sub6，统计Sub tongji()车次统计，见统计月报1.xlsExcel论坛 Dim 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

24、Sheets(Sht.Name).Select Range(a1).Select Myrow1 = a65536.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

25、.FormulaR1C1 = =R-1C Range(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).Row Myrow1 = Myrow1 - 1 Range(Cel

26、ls(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).Select Myrow2 = a65536.End(xlUp).Row Myrow2 = Myrow2 - 1 For y = 4 To Myrow2 fa1 = Range(a & y).Valu

27、e dao1 = Range(b & y).Value If fa = fa1 And dao = dao1 Then Sht1.Range(d & x) = Sht1.Range(d & x) + Range(d & y) 汇总 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 & y) Sht1.Range(h & x) = Sht1.

28、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 & 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

29、，最大或最小Excel论坛最大或最小.xlsSub MaxMin()Dim rng1 As RangeDim 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 = Applicatio

30、n.WorksheetFunction.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(a14).For

31、mulaR1C1 = 最小 Else End IfEnd IfEnd Sub8，最后一记录（定义名称）Sub zhytjl0206()最后一次的那条记录.xlsShizx982007-2-6/dispbbs.asp?BoardID=3&ID=&replyID=&skin=0 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 I

32、nteger Dim pp, pp1 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).Select Se

33、lection.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列数据的行数 Set minc = Range(a2:a & Myrow1) Set rng1 = Range(n2:n & Myrow1

34、) 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 = Sht1.Range(p & 2).Value 将行数赋给变量pp Range(Cells(pp, 7), Cells(pp + aa - 1, 7).Select Selection.Copy Sht2.Range(b2) 时间复制到表2 Sht2.Activate Ce

35、lls(2, 3).Select Selection.Formula = =datevalue(rc-1)+timevalue(rc-1) 时间值公式 If aa 1 Then Selection.AutoFill 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

36、, Orientation:=xlTopToBottom, SortMethod _ :=xlPinYin 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: Nex

37、t x Sht1.Activate Range(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 _ :=xlPinYin加边框 转加边框宏 Ran

38、ge(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.AutoFill Destination:=rng1, Type:=xlFillDefault 公式往下复制 b = Application.WorksheetFunction.CountIf(rng1,

39、4*)End SubSub FuzulieGS()某个不重复值的个数和所在行数的数组公式 Sht1.Select Set a = Range(n & x) aa = Application.WorksheetFunction.CountIf(minc, a) 计算某个不重复值的个数 Range(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),

40、),row(1:1),small(if(minc=$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) = xlEdgeRight BorderVars(5) = xlInside

41、Vertical 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 .Weight = xlThin .ColorIndex = xlAutomatic End

42、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 Worksheet, Sht2 As Worksheet Dim BorderVars(6) As Variant On Error Resume Next Appli

43、cation.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(a1).Select Selection.CurrentRegio