Excel自编宏大全Word版Word文档下载推荐.docx

1、 Dim Myrow As Integer Dim Myrow1 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列数据的行数a1 Myrow3 = Selection.CurrentRegion.Rows.Count AB列数据的行数 Set Myrng1 = Range（Cells（2

2、, 1）, 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

3、GoTo 100F1 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 200100: Next y200: Next xEnd Sub2007/1/30部分字符地址查找.xlsSub bfzfcz（） Dim x%,

4、 y1%, y2%, gg% Dim AA, BB On Error Resume Nexta2e1 Myrow2 = Selection.Rows.Count gg = 2 For x = 2 To Myrow2 AA = Range（e For y1 = 2 To Myrow1 + 1 BB = Application.WorksheetFunction.SearchB（AA, Cells（y1, 1） If BB 0 Theng gg） = A y1 gg = gg + 1 BB = 0 Next y1 For y2 = 2 To Myrow1 + 1 BB = Application.

5、WorksheetFunction.SearchB（AA, Cells（y2, 2）B y2 Next y2 gg = gg + 1Sub 宏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 清除总表原有的数据 S

6、et tbl = ActiveCell.CurrentRegion If tbl.Rows.Count 1 Then tbl.Offset（1, 0）.Resize（tbl.Rows.Count - 1, tbl.Columns.Count）.ClearContents n = 2使用型号表 Myrow1=a65536.End（xlUp）.Row A列最下面一行的行数，中间有空格也行 For x = 2 To Myrow1 Set rng1 = Range（ x） 依次把“使用数量”的值赋给rng1变量 rng2 = Range（ x）.Text 把序号里的表格名赋给rng2变量 If rng

7、1.Value Then）.Cells（1, 6）.Value = rng1.Value Sheets（rng2）.Select 用表格名选择表格 Myrow2 = Selection.CurrentRegion.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将使

8、用数量X数量 Range（Cells（n, 6）, Cells（Myrow2 + n - 2, 6）.Copy Cells（n, 5）.SelectSelection.PasteSpecial Paste:=xlValues以“选择性粘贴”的“数值”粘贴 Range（Cells（n, 6）, Cells（Myrow2 + n - 2, 6）.ClearContents 清除F列数量 Cells（1, 6）.ClearContents n = n + Myrow2 - 1 为下次粘贴数据的行位置 bcfhz0204 不重复汇总的宏 Application.ScreenUpdating = Tru

9、eSub bcfhz0204（）不重复汇总2007-2-4 Dim b As Integer, x As Integer, y As Integer, aa As Integer, yyy As Integer Dim minc As Range Dim rng1 As Range, a As Range Dim n1 As Integer, nn As Integer, Myrow1 As Integer Dim pp, pp1 Myrow1 = Selection.CurrentRegion.Rows.Count A列数据的行数 Set minc = Range（b2:b Myrow1）m

10、2:mm2求重复值个数的辅助列公式 Selection.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）n2求重复值的辅助列公式=if（iserror（index（minc,match（row（b1）,m$2:m$65536,0）,index（minc,match（row

11、（b1）,m$2:m$65536,0）=Range（n2:n b + 1）, Type:Range（ b + 1）.Select以“选择性粘贴”的“数值”粘贴n,m列，因为删除一行后，公式会重新计算 Selection.Copy Selection.PasteSpecial Paste: rng1.Select For x = 2 To b + 1 aa = Application.WorksheetFunction.CountIf（minc, a） 计算重复值的个数o x）.Value = aa nn = aap1） = ap2重复值所在行数的数组公式 Selection.FormulaAr

12、ray = =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以“选择性粘贴”的“数值”粘贴去除公式影响 For y = 2 To nn 在重复值里循环比较 pp = Range（ y）.Value 将行数赋给变量pp For yy = y + 1 To nn + 1 pp1 = Range（ yy）.Value 将行数赋给变量pp1 If pp1 = If Cells

13、（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:删除多余的行 For yyy = yy + 1 To nn + 1 yyy） = Range（ yyy） - 1 Next yyy yy）.Delete shift: yy = yy - 1: nn = nn - 1

14、 Next yyp1:P aa + 1）.ClearContents 清除辅助列数据m1 Selection.CurrentRegion.ClearContents A1以下在A列加上序号 n1 = Selection.CurrentRegion.Rows.CountA2 ActiveCell.FormulaR1C1 = 1A32A2: n1）, Type:Sub Sheetsname（）见上例的xls2007-2-2Dim Sht As WorksheetSheets（n = 2For Each Sht In ActiveWorkbook.Worksheets If Sht.Name And

15、 Sht.Name ActiveSheet.Range（k n） = Sht.Namel n） = Sht.Index n = n + 1Next ShtSub 重复值加色（）重复值加色.xls 蓝桥玄霜 2007-2-2表格中有重复值公式 Dim rng1 As Range, data As Range Dim b As Integern117） 重复值区域 b = Application.WorksheetFunction.Max（rng1） 重复值个数B2:B117 Selection.FormatConditions.Delete For X = 2 To b + 1 用查找 Sele

16、ction.FormatConditions.Add Type:=xlCellValue, Operator:=xlEqual, _ Formula1:=$M$ X Selection.FormatConditions（X - 1）.Interior.ColorIndex = 3 Next XSub tongji（）车次统计，见统计月报1.xlsExcel论坛 Dim Sht As Worksheet, Sht1 As Worksheet For Each Sht In ActiveWorkbook.Worksheets AB列空格填充月计 Sheets（Sht.Name）.Select My

17、row1 = a65536.End（xlUp）.Row Set rng1 = Range（Cells（4, 1）, Cells（Myrow1 - 1, 2） If IsError（Selection.SpecialCells（xlCellTypeBlanks） Then Selection.SpecialCells（xlCellTypeBlanks）.SelectA5=R-1CA4 Application.CutCopyMode = False Next Sht Set Sht1 = Sheets（）Myrow1 = a65536.End（xlUp）.Row Myrow1 = Myrow1 -

18、 1 Range（Cells（4, 4）, Cells（Myrow1, 11）.ClearContents For x = 4 To Myrow1 fa = Range（a x）.Value dao = Range（ If fa = And dao = For n = 1 To 10 Sheets（n）.Activate Myrow2 = a65536.End（xlUp）.Row Myrow2 = Myrow2 - 1 For y = 4 To Myrow2 fa1 = Range（ y）.Value dao1 = Range（ If fa = fa1 And dao = dao1 Then

19、Sht1.Range（d x） = Sht1.Range（ x） + Range（ y） 汇总 y）fhij Next nApplication.ScreenUpdating = True最大或最小.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）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 = Applicati