Excel自编宏大全.doc

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

2、行的行数（各个值的个数、行数） 22，分表自动字体格式化 23，自动填充数字 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 M

3、yrow1 As Integer Dim Myrow2 As 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(Cells(2, 1),

4、 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) End If If Myrow = 0 Then GoT

5、o 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 MsgBox “已找到！ “ GoTo 200 End If 100: Next

6、 y 200: Next x End Sub 2，部分字符地址查找 2007/1/30 部分字符地址查找 .xls Sub 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 Range(“e1“).Select Selection.CurrentRegion.Select M

7、yrow2 = 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“ & y1 gg = gg + 1 Else End If BB = 0 Next y1 For y2 = 2 To Myrow1 + 1 BB = Application.WorksheetFunction.

8、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 x End Sub 3，多表查询汇总和重复值问题（相同行删除、循环比较） 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 In

9、teger, Myrow2 As Integer Dim rng2 Application.ScreenUpdating = False Sheets(“汇总 “).Select 清除总表原有的数据 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 Ra

10、nge(“a1“).Select Myrow1=a65536.End(xlUp).Row A列最下面一行的行数，中间有空格也行 For x = 2 To Myrow1 Sheets(“使用型号表 “).Select Set rng1 = Range(“B“ & x) 依次把“使用数量”的值赋给 rng1 变量 rng2 = Range(“A“ & x).Text 把序号里的表格名赋给 rng2 变量 If rng1.Value 1)*(match($b2,minc,0)=row($a1),count(m$1:m1)+1,“)“ Selection.AutoFill Destination:=r

11、ng1, Type:=xlFillDefault 公式往下复制 b = Application.WorksheetFunction.Max(rng1) Range(“n2“).Select 求重复值的辅助列公式 Selection.Formula = “=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 公式往

12、下复制 Range(“n2:n“ & b + 1).Select 以“选择性粘贴”的“数值”粘贴 n,m 列，因为删除一行后，公式会重新计算 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.WorksheetFun

13、ction.CountIf(minc, a) 计算重复值的个数 Range(“o“ & x).Value = aa nn = aa Range(“p1“) = a Range(“p2“).Select 重复值所在行数的数组公式 Selection.FormulaArray = “=if($p$1 “汇总 “ And Sht.Name “月计 “ Then Sheets(Sht.Name).Select Range(“a1“).Select Myrow1 = a65536.End(xlUp).Row A列最下面一行的行数，中间有空格也行 Set rng1 = Range(Cells(4, 1),

14、 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(“A4“).Select rng1.Select Selection.Copy Selection.PasteSpecial Paste:=xlValues Applicati

15、on.CutCopyMode = False Range(“A4“).Select End If Else End If 100: Next Sht Sheets(“月计 “).Select Set Sht1 = Sheets(“月计 “) Range(“a1“).Select Myrow1 = a65536.End(xlUp).Row Myrow1 = Myrow1 - 1 Range(Cells(4, 4), Cells(Myrow1, 11).ClearContents For x = 4 To Myrow1 fa = Range(“a“ & x).Value dao = Range(“

16、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).Value dao1 = Range(“b“ & y).Value If fa = fa1 And dao = dao1 Then Sht1.Range(“d“ & x) = Sht1.

17、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.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)