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 Shizx98Dim a As Range, Myrng1 As Range, Myrng2 As RangeDim Myrow As IntegerDim Myrow1 As IntegerDim Myrow2
3、As IntegerDim Myrow3 As IntegerDim x As IntegerWorksheets(“Sheet1“).ActivateRange(“d2“).SelectSelection.CurrentRegion.SelectMyrow2 = Selection.Rows.Count D 列数据的行数Range(“a1“).SelectMyrow3 = Selection.CurrentRegion.Rows.Count AB 列数据的行数Set Myrng1 = Range(Cells(2, 1), Cells(Myrow3, 1)Set Myrng2 = Range(
4、Cells(2, 2), Cells(Myrow3, 2)For x = 2 To Myrow2 + 1Set a = Range(“D“ & x)For y = 1 To Myrow3If Len(a) 7 ThenMyrow = Application.WorksheetFunction.Match(a, Myrng1, 0)ElseMyrow = Application.WorksheetFunction.Match(a, Myrng2, 0)End IfIf Myrow = 0 ThenGoTo 100ElseRange(“F1“).SelectSelection.CurrentReg
5、ion.SelectMyrow1 = Selection.Rows.CountRange(Cells(Myrow + 1, 1), Cells(Myrow + 1, 2).SelectSelection.Cut Destination:=Range(Cells(Myrow1 + 1, 6), Cells(Myrow1 + 1, 7)Selection.Delete Shift:=xlUpMyrow = 0MsgBox “已找到！“GoTo 200End If100: Next y200: Next xEnd Sub2，部分字符地址查找2007/1/30部分字符地址查找.xlsSub bfzfc
6、z()Dim Myrow1 As IntegerDim Myrow2 As IntegerDim x%, y1%, y2%, gg%Dim AA, BBOn Error Resume NextRange(“a2“).SelectSelection.CurrentRegion.SelectMyrow1 = Selection.Rows.CountRange(“e1“).SelectSelection.CurrentRegion.SelectMyrow2 = Selection.Rows.Countgg = 2For x = 2 To Myrow2AA = Range(“e“ & x)For y1
7、 = 2 To Myrow1 + 1BB = Application.WorksheetFunction.SearchB(AA, Cells(y1, 1)If BB 0 ThenRange(“g“ & gg) = “A“ & y1gg = gg + 1ElseEnd IfBB = 0Next y1For y2 = 2 To Myrow1 + 1BB = Application.WorksheetFunction.SearchB(AA, Cells(y2, 2)If BB 0 ThenRange(“g“ & gg) = “B“ & y2gg = gg + 1ElseEnd IfBB = 0Nex
8、t y2gg = gg + 1Next xEnd Sub3，多表查询汇总和重复值问题（相同行删除、循环比较）Sub 宏 0204()见汇总 0204.xls 2007-2-4蓝桥玄霜大汇总问题Dim x As Integer, y As IntegerDim rng1 As Range, tbl As RangeDim n As IntegerDim Myrow1 As Integer, Myrow2 As IntegerDim rng2Application.ScreenUpdating = FalseSheets(“汇总“).Select 清除总表原有的数据Range(“a1“).Sele
9、ctSet tbl = ActiveCell.CurrentRegionIf tbl.Rows.Count 1 Thentbl.Offset(1, 0).Resize(tbl.Rows.Count - 1, tbl.Columns.Count).ClearContentsElseEnd Ifn = 2Sheets(“使用型号表“).SelectRange(“a1“).SelectMyrow1=a65536.End(xlUp).Row A 列最下面一行的行数，中间有空格也行For x = 2 To Myrow1Sheets(“使用型号表 “).SelectSet rng1 = Range(“B“
10、 & 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:=rng1, Type:=xlFillDefault 公式往下复制b = Application.WorksheetFunction.Max(rng1)Range(“n2“).Select 求重复值的辅助列公式Selection.Formula = “=if(ise
11、rror(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 列，因为删除一行后，公式会重新计算 Selection.CopyRange(“n2“).SelectSelection.PasteSpecial Paste:=xlVa
12、luesrng1.SelectSelection.CopyRange(“m2“).SelectSelection.PasteSpecial Paste:=xlValuesFor x = 2 To b + 1Set a = Range(“n“ & x)aa = Application.WorksheetFunction.CountIf(minc, a) 计算重复值的个数Range(“o“ & x).Value = aann = aaRange(“p1“) = aRange(“p2“).Select 重复值所在行数的数组公式Selection.FormulaArray = “=if($p$1 “汇
13、总“ And Sht.Name “月计“ ThenSheets(Sht.Name).SelectRange(“a1“).SelectMyrow1 = a65536.End(xlUp).Row A 列最下面一行的行数，中间有空格也行Set rng1 = Range(Cells(4, 1), Cells(Myrow1 - 1, 2)rng1.SelectIf IsError(Selection.SpecialCells(xlCellTypeBlanks) ThenGoTo 100ElseSelection.SpecialCells(xlCellTypeBlanks).SelectRange(“A5
14、“).ActivateSelection.FormulaR1C1 = “=R-1C“Range(“A4“).Selectrng1.SelectSelection.CopySelection.PasteSpecial Paste:=xlValuesApplication.CutCopyMode = FalseRange(“A4“).SelectEnd IfElseEnd If100: Next ShtSheets(“月计“).SelectSet Sht1 = Sheets(“月计“)Range(“a1“).SelectMyrow1 = a65536.End(xlUp).Row Myrow1 =
15、Myrow1 - 1Range(Cells(4, 4), Cells(Myrow1, 11).ClearContentsFor x = 4 To Myrow1fa = Range(“a“ & x).Valuedao = Range(“b“ & x).ValueIf fa = “ And dao = “ ThenGoTo 200ElseEnd IfFor n = 1 To 10Sheets(n).ActivateRange(“a1“).SelectMyrow2 = a65536.End(xlUp).RowMyrow2 = Myrow2 - 1For y = 4 To Myrow2fa1 = Ra
16、nge(“a“ & y).Valuedao1 = Range(“b“ & y).ValueIf fa = fa1 And dao = dao1 ThenSht1.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) + Ran
17、ge(“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)Sht1.Range(“k“ & x) = Sht1.Range(“k“ & x) + Range(“k“ & y)ElseEnd IfNext yNext nSheets(“月计“).Select200: Next xSheet
18、s(“月计“).SelectApplication.ScreenUpdating = TrueEnd Sub7，最大或最小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(“/“, rng
19、1)a(x) = Left(rng1, b)a(x) = Val(a(x)Next xMymax = Application.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 ThenRange(“
20、a14“).FormulaR1C1 = “最大“ElseIf a(1) = Mymin ThenRange(“a14“).FormulaR1C1 = “最小“ElseEnd IfEnd IfEnd Sub8，最后一记录（定义名称）Sub zhytjl0206()最后一次的那条记录.xlsShizx982007-2-6http:/ b As Integer, x As Integer, y As Integer, aa As IntegerDim minc As RangeDim rng1 As Range, a As RangeDim nn As Integer, Myrow1 As Inte
21、gerDim pp, pp1Dim Sht1 As Worksheet, Sht2 As WorksheetOn Error Resume NextApplication.ScreenUpdating = FalseSet Sht1 = Sheets(1): Set Sht2 = Sheets(3)Sht1.ActivateActiveWorkbook.Names.Add Name:=“data1“, RefersToR1C1:= _“=OFFSET(Sheet1!R1C1,1,COUNTA(Sheet1!R2C1:R65535C1),)“Range(“n1“).SelectSelection
22、.CurrentRegion.ClearContents 清除辅助列数据Sheet2.ActivateRange(“a1“).SelectSelection.CurrentRegion.ClearContents 清除上次数据Sht1.Range(“a1:g1“).Copy Sheet2.a1Sht1.ActivateRange(“a1“).SelectMyrow1 = Selection.CurrentRegion.Rows.Count A 列数据的行数Set minc = Range(“a2:a“ & Myrow1)Set rng1 = Range(“n2:n“ & Myrow1)Bcfz
23、GS 转求不重复值宏For x = 2 To b + 1FuzulieGS 转辅助列公式宏Range(“p2:p“ & aa + 1).SelectSelection.Copy Sht2.Range(“a2“)Application.CutCopyMode = FalseSht1.Activatepp = Sht1.Range(“p“ & 2).Value 将行数赋给变量 ppRange(Cells(pp, 7), Cells(pp + aa - 1, 7).SelectSelection.Copy Sht2.Range(“b2“) 时间复制到表 2Sht2.ActivateCells(2,
24、3).SelectSelection.Formula = “=datevalue(rc-1)+timevalue(rc-1)“ 时间值公式If aa 1 ThenSelection.AutoFill Destination:=Range(“c2:c“ & aa + 1), Type:=xlFillDefault 公式往下复制Range(“a2:c“ & aa + 1).SelectSelection.Sort Key1:=Range(“C2“), Order1:=xlDescending, Header:=xlNo, _OrderCustom:=2, MatchCase:=False, Ori
25、entation:=xlTopToBottom, SortMethod _:=xlPinYinElseEnd Ifpp1 = Range(“a2“).ValueSheets(2).SelectFor xx = 1 To 7Cells(x, xx) = Sht1.Cells(pp1, xx)Next xxnn = aaSht1.ActivateRange(“p1:P“ & aa + 1).ClearContents 清除辅助列数据Sht2.ActivateRange(Cells(1, 1), Cells(aa + 1, 3).ClearContents200: Next xSht1.Activa
26、teRange(“m1“).SelectSelection.CurrentRegion.ClearContents 清除辅助列数据Sheets(2).ActivateRange(“a1:g“ & b + 1).Select 排序Selection.Sort Key1:=Range(“a1“), Order1:=xlAscending, Header:=xlGuess, _OrderCustom:=2, MatchCase:=False, Orientation:=xlTopToBottom, SortMethod _:=xlPinYin加边框 转加边框宏Range(“A1“).SelectAp
27、plication.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, “4*“)End SubSub
28、FuzulieGS()某个不重复值的个数和所在行数的数组公式Sht1.SelectSet a = Range(“n“ & x)aa = Application.WorksheetFunction.CountIf(minc, a) 计算某个不重复值的个数Range(“o“ & x).Value = aann = aaRange(“p1“) = Val(a)Range(“p2“).Select 某个不重复值所在行数的数组公式Selection.FormulaArray = “=if($p$1 1 ThenSelection.AutoFill Destination:=Range(“p2:p“ &
29、aa + 1), Type:=xlFillDefaultElseEnd IfEnd SubSub 加边框()BorderVars(1) = xlEdgeLeftBorderVars(2) = xlEdgeTopBorderVars(3) = xlEdgeBottomBorderVars(4) = xlEdgeRightBorderVars(5) = xlInsideVerticalBorderVars(6) = xlInsideHorizontalRange(“a1:g“ & b + 1).SelectSelection.Borders(xlDiagonalDown).LineStyle =
30、xlNoneSelection.Borders(xlDiagonalUp).LineStyle = xlNoneFor x = 1 To 6With Selection.Borders(BorderVars(x).LineStyle = xlContinuous.Weight = xlThin.ColorIndex = xlAutomaticEnd WithNextEnd SubSub zhytjl0215()最后一条记录 0215.xls蓝桥玄霜,2007-2-15根据 czzqb 的数组公式修改在表 1 的 H 列加了时间转换公式Dim b As Integer, x As Integer
31、, y As IntegerDim minc As RangeDim rng1 As Range, a As RangeDim Myrow1 As IntegerDim Sht1 As Worksheet, Sht2 As WorksheetDim BorderVars(6) As VariantOn Error Resume NextApplication.ScreenUpdating = FalseSet Sht1 = Sheets(1): Set Sht2 = Sheets(2)Sht1.Activate 定义动态区域名称ActiveWorkbook.Names.Add Name:=“d
32、ata1“, 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“).SelectSelection.CurrentRegion.ClearContents Sheet2.ActivateRange(“a1“).SelectSelection.CurrentRegion.
33、ClearContents Sht1.Range(“a1:g1“).Copy Sheet2.a1Sht1.ActivateRange(“a1“).SelectMyrow1 = Selection.CurrentRegion.Rows.Count Set minc = Range(“a2:a“ & Myrow1)Set rng1 = Range(“n2:n“ & Myrow1)Range(“n2“).Select 辅助列公式求不重复值Selection.FormulaArray = “=index(a:a,min(if(countif(n$1:n1,minc),65536,row(minc)&“
34、Selection.AutoFill Destination:=rng1, Type:=xlFillDefault 不重复值的个数b = Application.WorksheetFunction.CountIf(rng1, “4*“)Range(“n2:n“ & b + 1).SelectSelection.CopySelection.PasteSpecial Paste:=xlValuesRange(Cells(2, 14), Cells(1 + b, 14).Copy Sht2.Cells(2, 1)Sht2.ActivateSht2.b2.SelectSelection.Formula
35、R1C1 = “=index(mydata,match(value(rc-1),data1,0),2)“Sht2.c2.SelectSelection.Formula = “=index(mydata,match(value(rc-2),data1,0),3)“Sht2.d2.SelectSelection.Formula = “=index(mydata,match(value(rc-3),data1,0),4)“Sht2.e2.SelectSelection.Formula = “=index(mydata,match(value(rc-4),data1,0),5)“Sht2.f2.Sel
36、ectSelection.Formula = “=index(mydata,match(value(rc-5),data1,0),6)“Sht2.g2.SelectSelection.FormulaArray = “=max(if(data1=value(rc-6),shiji)“ 求时间最后的数组公式，by:czzqbRange(“b2:g2“).SelectSelection.AutoFill Destination:=Range(“b2:g“ & b + 1), Type:=xlFillDefaultSheets(2).ActivateRange(“a1:g“ & b + 1).Sele
37、ct 排序Selection.Sort Key1:=Range(“a1“), Order1:=xlAscending, Header:=xlGuess, _OrderCustom:=2, MatchCase:=False, Orientation:=xlTopToBottom, SortMethod _:=xlPinYinSelection.Borders(xlDiagonalDown).LineStyle = xlNoneSelection.Borders(xlDiagonalUp).LineStyle = xlNone加边框BorderVars(1) = xlEdgeLeftBorderV
38、ars(2) = xlEdgeTopBorderVars(3) = xlEdgeBottomBorderVars(4) = xlEdgeRightBorderVars(5) = xlInsideVerticalBorderVars(6) = xlInsideHorizontalFor x = 1 To 6With Selection.Borders(BorderVars(x).LineStyle = xlContinuous.Weight = xlThin.ColorIndex = xlAutomaticEnd WithNextrng1.ClearContentsRange(“A1“).Sel
39、ectApplication.ScreenUpdating = TrueEnd Sub9，大港表格转换大港.xlsSub dagang()Dim Sht1 As Worksheet, Sht2 As WorksheetDim x As Integer, y As IntegerDim n As Integer, m As IntegerDim n1 As IntegerApplication.ScreenUpdating = FalseSet Sht1 = ActiveWorkbook.Sheets(1)Set Sht2 = Sheets(2)Sht2.Activate 清除原有数据Range
40、(“a1“).SelectActiveCell.CurrentRegion.ClearContentsWith Sht2 表格的表头赋值.Cells(1, 1) = “编号“.Cells(1, 2) = “姓名“.Cells(1, 3) = “性别“.Cells(1, 4) = “年龄“.Cells(1, 5) = “职务“.Cells(1, 6) = “家庭地址 “.Cells(1, 7) = “户口性质及所在地 “.Cells(1, 8) = “身体状况 “.Cells(1, 9) = “备注“End Withn = 2: m = 2For x = 1 To 9For y = 3 To 1
41、68 Step 11 两分表间隔 11 行If Sht1.Cells(y, m) rc-2),1,“)“Selection.AutoFill Destination:=Range(“i1:i“ & Myrow1), Type:=xlFillDefault 判断三位尾数相等Range(“o1“) = “尾数三位相同 “ BAAACase 4Range(“j1“).SelectSelection.Formula = “=if(and(rc-6=rc-5,rc-5rc-3),1,“)“ 判断两位尾数相等Selection.AutoFill Destination:=Range(“j1:j“ & My
42、row1), Type:=xlFillDefaultRange(“p1“) = “尾数两位相同 “ AACase 5Range(“k1“).SelectSelection.Formula = “=if(and(rc-6=rc-7,rc-4=rc-5,rc-5rc-8,rc-5=rc-6),1,“)“ AAABSelection.AutoFill Destination:=Range(“l1:l“ & Myrow1), Type:=xlFillDefaultRange(“r1“) = “尾数 AAAB“Case 7Range(“m1“).SelectSelection.Formula = “=i
43、f(and(rc-9=rc-7,rc-8=rc-6,rc-7 “ ThenCells(n, 5) = Cells(x, 1): Cells(n, 6) = Cells(y, 2)n = n + 1: xx = 1Cells(x, 1).Delete shift:=xlUpCells(y, 2).Delete shift:=xlUpnn = nn - 1y = y - 1ElseEnd IfNext yIf xx = 1 Thenx = x - 1ElseEnd IfIf nn 1 ThenRange(Cells(n, 1), Cells(n + a - 1, 13).SelectSelecti
44、on.Delete shift:=xlUpElseEnd If100: Next yRange(“q1:q“ & gesu + 1).ClearContentsRange(“p1“).ClearContentsEnd IfEnd If200: StopNext xApplication.ScreenUpdating = TrueEnd Sub14，物品领用报表Sub 宏 9() 赋予“报表制表”按钮的宏 Macro进出货领用表.xls 蓝桥玄霜 2006-12-19Dim PitItemVar As PivotItemDim Pivot1 As PivotTableDim MyItem As
45、VariantDim x, y, xx, xcolumn As IntegerDim BorderVars(6) As VariantDim yearcpage, monthcpage As Variant“打印报表”原有的数据行删除Worksheets(“打印报表“).SelectRange(“1:100“).SelectSelection.Delete Shift:=xlUpRange(“a1“).Select边框的常数赋值BorderVars(1) = xlEdgeLeftBorderVars(2) = xlEdgeTopBorderVars(3) = xlEdgeBottomBorde
46、rVars(4) = xlEdgeRightBorderVars(5) = xlInsideVerticalBorderVars(6) = xlInsideHorizontalxcolumn = 0清除原有领用部门名称的 aa1、ab1 列数据Worksheets(“部门领用汇总“).SelectSet Pivot1 = ActiveSheet.PivotTables(“数据透视表 1“)Range(“aa1:ab1“).SelectSelection.EntireColumn.ClearContentsRange(“b12“).SelectSelection.CurrentRegion.Se
47、lectxcolumn = Pivot1.PivotFields(“领用部门“).PivotItems.CountMsgBox xcolumnStopRange(“aa1“).Select排序For Each PitItemVar In Pivot1.PivotFields(“领用部门“).PivotItemsMsgBox PitItemVar.Name & “ Position = “ & PitItemVar.PositionSelection.Value = PitItemVar.NameRange(“ab1“).Value = PitItemVar.PositionSelection.
48、Offset(rowoffset:=1).SelectNextRange(“AB1“).SelectActiveCell.FormulaR1C1 = “=INDEX(bumenxuhao,MATCH(RC-1,bumen,0),2)“Range(“AB1“).SelectSelection.AutoFill Destination:=Range(Cells(1, 28), Cells(xcolumn, 28), _Type:=xlFillDefaultRange(“AB1“).SelectRange(Cells(1, 27), Cells(xcolumn, 28).SelectSelection.Sort Key1:=Range(“AB1“), Order1:=xlAscending, Header:=xlGuess, _OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, SortMethod _:=xlPinYinRange(“Aa1“).SelectMyItem = “MyItem
