Excel自编宏大全(Word版)

目录1，从数据源匹配取数的问题2，部分字符地址查找3，多表查询汇总和重复值问题（相同行删除、循环比较）4，工作表的名称和index号5，重复值加色6，统计7，最大或最小8，最后一记录（定义动态区域名称、不重复值公式宏、不重复值个数和行数公式宏、加边框宏）9，大港表格转换10，筛选尾数11，对比数据12，修改批注字体13，删除合并单元格14，物品领用报表15，条件格式设置16，多表查询，自动筛选法17，多条件查询累计汇总18，和值19，教师安排汇总（循环比较、不重复值）20，自动着色（不同个数、不同颜色）21，不重复值的个数及所在行的行数（各个值的个数、行数）22，分表自动字体格式化23，自动填充数字24，导入文本文件25，累计不变化（内部循环）26，同结构多表统计汇总（Consolidate方法）27，资产负债表汇总（多工作簿汇总）28，导出到文本文件29，角度求和的自定义公式30，表单输入模板31，两表间复制与核对1，从数据源匹配取数的问题Sub宏131()'从数据源匹配取数的问题131.xls'2007-1-31'Shizx98'DimaAsRange,Myrng1AsRange,Myrng2AsRangeDimMyrowAsIntegerDimMyrow1AsIntegerDimMyrow2AsIntegerDimMyrow3AsIntegerDimxAsIntegerWorksheets(Sheet1).ActivateRange(d2).SelectSelection.CurrentRegion.SelectMyrow2=Selection.Rows.Count'D列数据的行数Range(a1).SelectMyrow3=Selection.CurrentRegion.Rows.Count'AB列数据的行数SetMyrng1=Range(Cells(2,1),Cells(Myrow3,1))SetMyrng2=Range(Cells(2,2),Cells(Myrow3,2))Forx=2ToMyrow2+1Seta=Range(D&x)Fory=1ToMyrow3IfLen(a)7ThenMyrow=Application.WorksheetFunction.Match(a,Myrng1,0)ElseMyrow=Application.WorksheetFunction.Match(a,Myrng2,0)EndIfIfMyrow=0ThenGoTo100ElseRange(F1).SelectSelection.CurrentRegion.SelectMyrow1=Selection.Rows.CountRange(Cells(Myrow+1,1),Cells(Myrow+1,2)).SelectSelection.CutDestination:=Range(Cells(Myrow1+1,6),Cells(Myrow1+1,7))Selection.DeleteShift:=xlUpMyrow=0MsgBox已找到！GoTo200EndIf100:Nexty200:NextxEndSub2，部分字符地址查找‘2007/1/30‘部分字符地址查找.xlsSubbfzfcz()DimMyrow1AsIntegerDimMyrow2AsIntegerDimx%,y1%,y2%,gg%DimAA,BBOnErrorResumeNextRange(a2).SelectSelection.CurrentRegion.SelectMyrow1=Selection.Rows.CountRange(e1).SelectSelection.CurrentRegion.SelectMyrow2=Selection.Rows.Countgg=2Forx=2ToMyrow2AA=Range(e&x)Fory1=2ToMyrow1+1BB=Application.WorksheetFunction.SearchB(AA,Cells(y1,1))IfBB0ThenRange(g&gg)=A&y1gg=gg+1ElseEndIfBB=0Nexty1Fory2=2ToMyrow1+1BB=Application.WorksheetFunction.SearchB(AA,Cells(y2,2))IfBB0ThenRange(g&gg)=B&y2gg=gg+1ElseEndIfBB=0Nexty2'gg=gg+1NextxEndSub3，多表查询汇总和重复值问题（相同行删除、循环比较）Sub宏0204()''见汇总0204.xls'2007-2-4'蓝桥玄霜'大汇总问题'DimxAsInteger,yAsIntegerDimrng1AsRange,tblAsRangeDimnAsIntegerDimMyrow1AsInteger,Myrow2AsIntegerDimrng2Application.ScreenUpdating=FalseSheets(汇总).Select'清除总表原有的数据Range(a1).SelectSettbl=ActiveCell.CurrentRegionIftbl.Rows.Count1Thentbl.Offset(1,0).Resize(tbl.Rows.Count-1,tbl.Columns.Count).ClearContentsElseEndIfn=2Sheets(使用型号表).SelectRange(a1).SelectMyrow1=[a65536].End(xlUp).Row'A列最下面一行的行数，中间有空格也行Forx=2ToMyrow1Sheets(使用型号表).SelectSetrng1=Range(B&x)'依次把“使用数量”的值赋给rng1变量rng2=Range(A&x).Text'把序号里的表格名赋给rng2变量Ifrng1.ValueThenSheets(汇总).Cells(1,6).Value=rng1.ValueSheets(rng2).Select'用表格名选择表格Range(a1).SelectMyrow2=Selection.CurrentRegion.Rows.Count'数据的行数Range(Cells(2,2),Cells(Myrow2,5)).Copy'复制这些数据Sheets(汇总).ActivateCells(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.PasteSpecialPaste:=xlValues'以“选择性粘贴”的“数值”粘贴Range(Cells(n,6),Cells(Myrow2+n-2,6)).ClearContents'清除F列数量Cells(1,6).ClearContentsn=n+Myrow2-1'为下次粘贴数据的行位置ElseEndIfNextxbcfhz0204'不重复汇总的宏Application.ScreenUpdating=TrueEndSubSubbcfhz0204()'不重复汇总'蓝桥玄霜'2007-2-4DimbAsInteger,xAsInteger,yAsInteger,aaAsInteger,yyyAsIntegerDimmincAsRangeDimrng1AsRange,aAsRangeDimn1AsInteger,nnAsInteger,Myrow1AsIntegerDimpp,pp1OnErrorResumeNextSheets(汇总).SelectRange(a1).SelectMyrow1=Selection.CurrentRegion.Rows.Count'A列数据的行数Setminc=Range(b2:b&Myrow1)Setrng1=Range(m2:m&Myrow1)Range(m2).Select'求重复值个数的辅助列公式Selection.Formula==if((countif(minc,$b2)1)*(match($b2,minc,0)=row($a1)),count(m$1:m1)+1,)Selection.AutoFillDestination:=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))),,index(minc,match(row(b1),m$2:m$65536,0)))Selection.AutoFillDestination:=Range(n2:n&b+1),Type:=xlFillDefault'公式往下复制Range(n2:n&b+1).Select'以“选择性粘贴”的“数值”粘贴n,m列，因为删除一行后，公式会重新计算'Selection.CopyRange(n2).SelectSelection.PasteSpecialPaste:=xlValuesrng1.SelectSelection.CopyRange(m2).SelectSelection.PasteSpecialPaste:=xlValuesForx=2Tob+1Seta=Range(n&x)aa=Application.WorksheetFunction.CountIf(minc,a)'计算重复值的个数Range(o&x).Value=aann=aaRange(p1)=aRange(p2).Select'重复值所在行数的数组公式Selection.FormulaArray==if($p$1,if(iserror(small(if(minc=$p$1,row(minc),),row(1:1))),,small(if(minc=$p$1,row(minc),),row(1:1))))Selection.AutoFillDestination:=Range(p2:p&aa+1),Type:=xlFillDefaultRange(p2:p&aa+1).SelectSelection.CopyRange(p2).SelectSelection.PasteSpecialPaste:=xlValues'以“选择性粘贴”的“数值”粘贴去除公式影响Fory=2Tonn'在重复值里循环比较pp=Range(p&y).Value'将行数赋给变量ppForyy=y+1Tonn+1pp1=Range(p&yy).Value'将行数赋给变量pp1Ifpp1=ThenGoTo100ElseEndIfIfCells(pp,2)=Cells(pp1,2)AndCells(pp,3)=Cells(pp1,3)AndCells(pp,4)=Cells(pp1,4)ThenCells(pp,5)=Cells(pp,5)+Cells(pp1,5)'汇总部分Range(Cells(pp1,1),Cells(pp1,5)).Deleteshift:=xlUp'删除多余的行Foryyy=yy+1Tonn+1Range(p&yyy)=Range(p&yyy)-1NextyyyRange(p&yy).Deleteshift:=xlUpyy=yy-1:nn=nn-1ElseEndIfNextyy100:Nextynn=aaRange(p1:P&aa+1).ClearContents'清除辅助列数据200:Ne