Excel自编宏大全Word版Word文件下载.docx

1、Dim Myrow1 As IntegerDim Myrow2 As IntegerDim Myrow3 As IntegerDim x As IntegerWorksheets（Sheet1）.ActivateRange（d2）.SelectSelection.CurrentRegion.SelectMyrow2 = Selection.Rows.Count D列数据的行数a1Myrow3 = Selection.CurrentRegion.Rows.CountAB列数据的行数Set Myrng1 = Range（Cells（2, 1）, Cells（Myrow3, 1）Set Myrng2

2、 = Range（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 100F1Myrow1 = Selection.Rows.CountRang

3、e（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 200100: Next y200: Next xEnd Sub2007/1/30部分字符地址查找.xlsSub bfzfcz（）Dim x%, y1%, y2%, gg%Dim AA, BBOn Error Resume Nexta2e1Myr

4、ow2 = Selection.Rows.Countgg = 2For x = 2 To Myrow2AA = Range（eFor y1 = 2 To Myrow1 + 1BB = Application.WorksheetFunction.SearchB（AA, Cells（y1, 1）If BB 0 Theng gg） = A y1gg = gg + 1BB = 0Next y1For y2 = 2 To Myrow1 + 1BB = Application.WorksheetFunction.SearchB（AA, Cells（y2, 2）B y2Next y2Next xSub 宏0

5、204（）见汇总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清除总表原有的数据Set tbl = ActiveCell.CurrentRegionIf tbl.Rows.Count 1 Thentbl.Offset（1, 0）.Resize

6、（tbl.Rows.Count - 1, tbl.Columns.Count）.ClearContentsn = 2使用型号表Myrow1=a65536.End（xlUp）.RowA列最下面一行的行数，中间有空格也行For x = 2 To Myrow1Set rng1 = Range（ x）依次把“使用数量”的值赋给rng1变量rng2 = Range（ x）.Text把序号里的表格名赋给rng2变量If rng1.Value Then）.Cells（1, 6）.Value = rng1.ValueSheets（rng2）.Select用表格名选择表格Myrow2 = Selection.C

7、urrentRegion.Rows.Count数据的行数Range（Cells（2, 2）, Cells（Myrow2, 5）.Copy复制这些数据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）.CopyCells（n, 5）.SelectSelection.PasteSpecial Paste:=

8、xlValues以“选择性粘贴”的“数值”粘贴Range（Cells（n, 6）, Cells（Myrow2 + n - 2, 6）.ClearContents清除F列数量Cells（1, 6）.ClearContentsn = n + Myrow2 - 1为下次粘贴数据的行位置bcfhz0204不重复汇总的宏Application.ScreenUpdating = TrueSub bcfhz0204（）不重复汇总2007-2-4Dim b As Integer, x As Integer, y As Integer, aa As Integer, yyy As IntegerDim minc

9、 As RangeDim rng1 As Range, a As RangeDim n1 As Integer, nn As Integer, Myrow1 As IntegerDim pp, pp1Myrow1 = Selection.CurrentRegion.Rows.CountA列数据的行数Set minc = Range（b2:b Myrow1）m2:mm2求重复值个数的辅助列公式Selection.Formula = =if（countif（minc,$b2）1）*（match（$b2,minc,0）=row（$a1）,count（m$1:m1）+1,）Selection.Auto

10、Fill Destination:=rng1, Type:=xlFillDefault公式往下复制b = Application.WorksheetFunction.Max（rng1）n2求重复值的辅助列公式=if（iserror（index（minc,match（row（b1）,m$2:m$65536,0）,index（minc,match（row（b1）,m$2:m$65536,0）=Range（n2:n b + 1）, Type: b + 1）.Select以“选择性粘贴”的“数值”粘贴n,m列，因为删除一行后，公式会重新计算Selection.Copyrng1.SelectFor x

11、= 2 To b + 1aa = Application.WorksheetFunction.CountIf（minc, a）计算重复值的个数o x）.Value = aann = aap1） = ap2重复值所在行数的数组公式Selection.FormulaArray = =if（$p$1,if（iserror（small（if（minc=$p$1,row（minc）,）,row（1:1）,small（if（minc=$p$1,row（minc）,1）p2:p aa + 1）, Type:=xlFillDefault aa + 1）.Select以“选择性粘贴”的“数值”粘贴去除公式影响F

12、or y = 2 To nn在重复值里循环比较pp = Range（ y）.Value将行数赋给变量ppFor yy = y + 1 To nn + 1pp1 = Range（ yy）.Value将行数赋给变量pp1If pp1 = If Cells（pp, 2） = Cells（pp1, 2） And Cells（pp, 3） = Cells（pp1, 3） And Cells（pp, 4） = Cells（pp1, 4） ThenCells（pp, 5） = Cells（pp, 5） + Cells（pp1, 5）汇总部分Range（Cells（pp1, 1）, Cells（pp1, 5）

13、.Delete shift:删除多余的行For yyy = yy + 1 To nn + 1 yyy） = Range（ yyy） - 1Next yyy yy）.Delete shift:yy = yy - 1: nn = nn - 1Next yyp1:P aa + 1）.ClearContents清除辅助列数据m1Selection.CurrentRegion.ClearContentsA1以下在A列加上序号n1 = Selection.CurrentRegion.Rows.CountA2ActiveCell.FormulaR1C1 = 1A32A2: n1）, Type:Sub She

14、etsname（）见上例的xls2007-2-2Dim Sht As WorksheetFor Each Sht In ActiveWorkbook.WorksheetsIf Sht.Name And Sht.Name ActiveSheet.Range（k n） = Sht.Namel n） = Sht.Indexn = n + 1Next ShtSub 重复值加色（）重复值加色.xls 蓝桥玄霜 2007-2-2表格中有重复值公式Dim rng1 As Range, data As RangeDim b As Integern117） 重复值区域b = Application.Worksh

15、eetFunction.Max（rng1） 重复值个数B2:B117Selection.FormatConditions.DeleteFor X = 2 To b + 1 用查找Selection.FormatConditions.Add Type:=xlCellValue, Operator:=xlEqual, _Formula1:=$M$ XSelection.FormatConditions（X - 1）.Interior.ColorIndex = 3Next XSub tongji（）车次统计，见统计月报1.xlsExcel论坛Dim Sht As Worksheet, Sht1 As

16、 WorksheetFor Each Sht In ActiveWorkbook.WorksheetsAB列空格填充月计Sheets（Sht.Name）.SelectMyrow1 = a65536.End（xlUp）.RowSet rng1 = Range（Cells（4, 1）, Cells（Myrow1 - 1, 2）If IsError（Selection.SpecialCells（xlCellTypeBlanks） ThenSelection.SpecialCells（xlCellTypeBlanks）.SelectA5=R-1CA4Application.CutCopyMode =

17、False Next ShtSet Sht1 = Sheets（） Myrow1 = Myrow1 - 1Range（Cells（4, 4）, Cells（Myrow1, 11）.ClearContentsFor x = 4 To Myrow1fa = Range（a x）.Valuedao = Range（If fa = And dao = For n = 1 To 10Sheets（n）.ActivateMyrow2 = a65536.End（xlUp）.RowMyrow2 = Myrow2 - 1For y = 4 To Myrow2fa1 = Range（ y）.Valuedao1 =

18、 Range（If fa = fa1 And dao = dao1 ThenSht1.Range（d x） = Sht1.Range（ x） + Range（ y）汇总 y）fhijNext yNext n最大或最小.xlsSub MaxMin（）Dim rng1 As RangeDim x As Integer, b As IntegerDim a（12）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）Mymax = 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（