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

'

Dim a As Range, Myrng1 As Range, Myrng2 As Range

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列数据的行数

Range("a1").Select

Myrow3 = Selection.CurrentRegion.Rows.Count 'AB列数据的行数

Set Myrng1 = Range(Cells(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

GoTo 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 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

Myrow2 = 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.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 Integer, 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

Range("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 <> "" Then

Sheets("汇总").Cells(1, 6).Value = rng1.V alue

Sheets(rng2).Select '用表格名选择表格

Range("a1").Select

Myrow2 = Selection.CurrentRegion.Rows.Count '数据的行数

Range(Cells(2, 2), Cells(Myrow2, 5)).Copy '复制这些数据

Sheets("汇总").Activate

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)).Copy '复制这些数据

Cells(n, 5).Select

Selection.PasteSpecial Paste:=xlValues

'以“选择性粘贴”的“数值”粘贴

Range(Cells(n, 6), Cells(Myrow2 + n - 2, 6)).ClearContents '清除F列数量

Cells(1, 6).ClearContents

n = n + Myrow2 - 1 '为下次粘贴数据的行位置

Else

End If

Next x

bcfhz0204 '不重复汇总的宏

Application.ScreenUpdating = True

End Sub

Sub 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

On Error Resume Next

Sheets("汇总").Select

Range("a1").Select

Myrow1 = Selection.CurrentRegion.Rows.Count 'A列数据的行数

Set minc = Range("b2:b" & Myrow1)

Set rng1 = 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.AutoFill Destination:=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.AutoFill Destination:=Range("n2:n" & b + 1), Type:=xlFillDefault '公式往下复制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.WorksheetFunction.CountIf(minc, a) '计算重复值的个数

Range("o" & x).Value = aa

nn = aa

Range("p1") = a

Range("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.AutoFill Destination:=Range("p2:p" & aa + 1), Type:=xlFillDefault

Range("p2:p" & aa + 1).Select

Selection.Copy

Range("p2").Select

Selection.PasteSpecial Paste:=xlValues

'以“选择性粘贴”的“数值”粘贴去除公式影响

For y = 2 To nn '在重复值里循环比较

pp = Range("p" & y).Value '将行数赋给变量pp

For yy = y + 1 To nn + 1

pp1 = Range("p" & yy).Value '将行数赋给变量pp1

If pp1 = "" Then

GoTo 100

Else

End If

If Cells(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:=xlUp '删除多余的行

For yyy = yy + 1 To nn + 1

Range("p" & yyy) = Range("p" & yyy) - 1

Next yyy

Range("p" & yy).Delete shift:=xlUp

yy = yy - 1: nn = nn - 1

Else

End If

Next yy

100: Next y

nn = aa

Range("p1:P" & aa + 1).ClearContents '清除辅助列数据

200: Next x

Range("m1").Select

Selection.CurrentRegion.ClearContents '清除辅助列数据

Range("A1").Select '以下在A列加上序号

n1 = Selection.CurrentRegion.Rows.Count

Range("A2").Select

ActiveCell.FormulaR1C1 = "1"

Range("A3").Select

ActiveCell.FormulaR1C1 = "2"

Range("A2:A3").Select

Selection.AutoFill Destination:=Range("A2:A" & n1), Type:=xlFillDefault Range("A2").Select

End Sub

4，工作表的名称和index号

Sub Sheetsname()

…见上例的xls

…2007-2-2

Dim Sht As Worksheet

Sheets("使用型号表").Activate

n = 2

For Each Sht In ActiveWorkbook.Worksheets

If https://www.360docs.net/doc/808768607.html, <> "汇总" And https://www.360docs.net/doc/808768607.html, <> "使用型号表" Then

ActiveSheet.Range("k" & n) = https://www.360docs.net/doc/808768607.html,

ActiveSheet.Range("l" & n) = Sht.Index

n = n + 1

Else

End If

Next Sht

End Sub

5，重复值加色

Sub 重复值加色()

'重复值加色.xls

' 蓝桥玄霜2007-2-2

'表格中有重复值公式

'

Dim rng1 As Range, data As Range

Dim b As Integer

Set rng1 = Range("n2:n117") …重复值区域

b = Application.WorksheetFunction.Max(rng1) …重复值个数

Range("B2:B117").Select

Selection.FormatConditions.Delete

For X = 2 To b + 1 …用查找

Selection.FormatConditions.Add Type:=xlCellValue, Operator:=xlEqual, _

Formula1:="=$M$" & X

Selection.FormatConditions(X - 1).Interior.ColorIndex = 3

Next X

End Sub

6，统计

Sub tongji()

…车次统计，见统计月报1.xls

…Excel论坛

Dim Myrow1 As Integer, Myrow2 As Integer

Dim Sht As Worksheet, Sht1 As Worksheet

Application.ScreenUpdating = False

On Error Resume Next

For Each Sht In ActiveWorkbook.Worksheets 'AB列空格填充

If https://www.360docs.net/doc/808768607.html, <> "月计" Then

Sheets(https://www.360docs.net/doc/808768607.html,).Select

Range("a1").Select

Myrow1 = [a65536].End(xlUp).Row 'A列最下面一行的行数，中间有空格也行

Set rng1 = Range(Cells(4, 1), 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[-1]C"

Range("A4").Select

rng1.Select

Selection.Copy

Selection.PasteSpecial Paste:=xlValues

Application.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("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.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)

Sht1.Range("k" & x) = Sht1.Range("k" & x) + Range("k" & y)

Else

End If

Next y

Next n

Sheets("月计").Select

200: Next x

Sheets("月计").Select

Application.ScreenUpdating = True

End Sub

7，最大或最小

…Excel论坛

…最大或最小.xls

Sub MaxMin()

Dim rng1 As Range

Dim x As Integer, b As Integer

Dim a(12)

Range("a14").Value = ""

For x = 1 To 12

Cells(2, x + 3).Select

Set rng1 = Cells(2, x + 3)

a(x) = Selection.Value

b = Application.WorksheetFunction.Find("/", rng1)

a(x) = Left(rng1, b)

a(x) = Val(a(x))

Next 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(8), a(9), a(10), a(11), a(12))

If a(1) = Mymax Then

Range("a14").FormulaR1C1 = "最大"

Else

If a(1) = Mymin Then

Range("a14").FormulaR1C1 = "最小"

Else

End If

End If

End Sub

8，最后一记录（定义名称）

Sub zhytjl0206()

'最后一次的那条记录.xls

'Shizx98

'2007-2-6

‘https://www.360docs.net/doc/808768607.html,/dispbbs.asp?BoardID=3&ID=219549&replyID=&skin=0

Dim b As Integer, x As Integer, y As Integer, aa As Integer

Dim minc As Range

Dim rng1 As Range, a As Range

Dim nn As Integer, Myrow1 As Integer

Dim pp, pp1

Dim Sht1 As Worksheet, Sht2 As Worksheet

On Error Resume Next

Application.ScreenUpdating = False

Set Sht1 = Sheets(1): Set Sht2 = Sheets(3)

Sht1.Activate

https://www.360docs.net/doc/808768607.html,s.Add Name:="data1", RefersToR1C1:= _

"=OFFSET(Sheet1!R1C1,1,,COUNTA(Sheet1!R2C1:R65535C1),)"

Range("n1").Select

Selection.CurrentRegion.ClearContents '清除辅助列数据

Sheet2.Activate

Range("a1").Select

Selection.CurrentRegion.ClearContents '清除上次数据

Sht1.Range("a1:g1").Copy Sheet2.[a1]

Sht1.Activate

Range("a1").Select

Myrow1 = Selection.CurrentRegion.Rows.Count 'A列数据的行数

Set minc = Range("a2:a" & Myrow1)

Set rng1 = Range("n2:n" & Myrow1)

BcfzGS '转求不重复值宏

For x = 2 To b + 1

FuzulieGS '转辅助列公式宏

Range("p2:p" & aa + 1).Select

Selection.Copy Sht2.Range("a2")

Application.CutCopyMode = False

Sht1.Activate

pp = Sht1.Range("p" & 2).Value '将行数赋给变量pp

Range(Cells(pp, 7), Cells(pp + aa - 1, 7)).Select

Selection.Copy Sht2.Range("b2") '时间复制到表2

Sht2.Activate

Cells(2, 3).Select

Selection.Formula = "=datevalue(rc[-1])+timevalue(rc[-1])" '时间值公式

If aa > 1 Then

Selection.AutoFill Destination:=Range("c2:c" & aa + 1), Type:=xlFillDefault '公式往下复制

Range("a2:c" & aa + 1).Select

Selection.Sort Key1:=Range("C2"), Order1:=xlDescending, Header:=xlNo, _ OrderCustom:=2, MatchCase:=False, Orientation:=xlTopToBottom, SortMethod _

:=xlPinYin

Else

End If

pp1 = Range("a2").Value

Sheets(2).Select

For xx = 1 To 7

Cells(x, xx) = Sht1.Cells(pp1, xx)

Next xx

nn = aa

Sht1.Activate

Range("p1:P" & aa + 1).ClearContents '清除辅助列数据

Sht2.Activate

Range(Cells(1, 1), Cells(aa + 1, 3)).ClearContents

200: Next x

Sht1.Activate

Range("m1").Select

Selection.CurrentRegion.ClearContents '清除辅助列数据

Sheets(2).Activate

Range("a1:g" & b + 1).Select …排序

Selection.Sort Key1:=Range("a1"), Order1:=xlAscending, Header:=xlGuess, _

OrderCustom:=2, MatchCase:=False, Orientation:=xlTopToBottom, SortMethod _

:=xlPinYin

加边框'转加边框宏

Range("A1").Select

Application.ScreenUpdating = True

End Sub

Sub 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 Sub

Sub FuzulieGS()

'某个不重复值的个数和所在行数的数组公式

Sht1.Select

Set a = Range("n" & x)

aa = Application.WorksheetFunction.CountIf(minc, a) '计算某个不重复值的个数

Range("o" & x).Value = aa

nn = aa

Range("p1") = Val(a)

Range("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))))"

If aa > 1 Then

Selection.AutoFill Destination:=Range("p2:p" & aa + 1), Type:=xlFillDefault Else

End If

End Sub

Sub 加边框()

BorderVars(1) = xlEdgeLeft

BorderVars(2) = xlEdgeTop

BorderVars(3) = xlEdgeBottom

BorderVars(4) = xlEdgeRight

BorderVars(5) = xlInsideVertical

BorderVars(6) = xlInsideHorizontal

Range("a1:g" & b + 1).Select

Selection.Borders(xlDiagonalDown).LineStyle = xlNone

Selection.Borders(xlDiagonalUp).LineStyle = xlNone

For x = 1 To 6

With Selection.Borders(BorderVars(x))

.LineStyle = xlContinuous

.Weight = xlThin

.ColorIndex = xlAutomatic

End With

Next

End Sub

Sub zhytjl0215()

'最后一条记录0215.xls

'蓝桥玄霜,

'2007-2-15

'根据czzqbμ的数组公式修改

'在表1的H列加了时间转换公式

Dim b As Integer, x As Integer, y As Integer

Dim minc As Range

Dim rng1 As Range, a As Range

Dim Myrow1 As Integer

Dim Sht1 As Worksheet, Sht2 As Worksheet

Dim BorderVars(6) As Variant

On Error Resume Next

Application.ScreenUpdating = False

Set Sht1 = Sheets(1): Set Sht2 = Sheets(2)

Sht1.Activate …定义动态区域名称

https://www.360docs.net/doc/808768607.html,s.Add Name:="data1", RefersToR1C1:= _ "=OFFSET(Sheet1!R1C1,1,,COUNTA(Sheet1!R2C1:R65535C1),)"

https://www.360docs.net/doc/808768607.html,s.Add Name:="shiji", RefersToR1C1:= _ "=OFFSET(Sheet1!R1C8,1,,COUNTA(Sheet1!R2C8:R65535C8),)"

Range("n1").Select

Selection.CurrentRegion.ClearContents

Sheet2.Activate

Range("a1").Select

Selection.CurrentRegion.ClearContents

Sht1.Range("a1:g1").Copy Sheet2.[a1]

Sht1.Activate

Range("a1").Select

Myrow1 = 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))))&"""""

Selection.AutoFill Destination:=rng1, Type:=xlFillDefault

…不重复值的个数

b = Application.WorksheetFunction.CountIf(rng1, "4*")

Range("n2:n" & b + 1).Select

Selection.Copy

Selection.PasteSpecial Paste:=xlValues

Range(Cells(2, 14), Cells(1 + b, 14)).Copy Sht2.Cells(2, 1)

Sht2.Activate

Sht2.[b2].Select

Selection.FormulaR1C1 = "=index(mydata,match(value(rc[-1]),data1,0),2)"

Sht2.[c2].Select

Selection.Formula = "=index(mydata,match(value(rc[-2]),data1,0),3)"

Sht2.[d2].Select

Selection.Formula = "=index(mydata,match(value(rc[-3]),data1,0),4)"

Sht2.[e2].Select

Selection.Formula = "=index(mydata,match(value(rc[-4]),data1,0),5)"

Sht2.[f2].Select

Selection.Formula = "=index(mydata,match(value(rc[-5]),data1,0),6)"

Sht2.[g2].Select

Selection.FormulaArray = "=max(if(data1=value(rc[-6]),shiji))" …求时间最后的数组公式，by:czzqb

Range("b2:g2").Select

Selection.AutoFill Destination:=Range("b2:g" & b + 1), Type:=xlFillDefault

Sheets(2).Activate

Range("a1:g" & b + 1).Select …排序

Selection.Sort Key1:=Range("a1"), Order1:=xlAscending, Header:=xlGuess, _

OrderCustom:=2, MatchCase:=False, Orientation:=xlTopToBottom, SortMethod _

:=xlPinYin

Selection.Borders(xlDiagonalDown).LineStyle = xlNone

Selection.Borders(xlDiagonalUp).LineStyle = xlNone

…加边框

BorderVars(1) = xlEdgeLeft

BorderVars(2) = xlEdgeTop

BorderVars(3) = xlEdgeBottom

BorderVars(4) = xlEdgeRight

BorderVars(5) = xlInsideVertical

BorderVars(6) = xlInsideHorizontal

For x = 1 To 6

With Selection.Borders(BorderVars(x))

.LineStyle = xlContinuous

.Weight = xlThin

.ColorIndex = xlAutomatic

End With

Next

rng1.ClearContents

Range("A1").Select

Application.ScreenUpdating = True

End Sub

9，大港表格转换

…大港.xls

Sub dagang()

Dim Sht1 As Worksheet, Sht2 As Worksheet

Dim x As Integer, y As Integer

Dim n As Integer, m As Integer

Dim n1 As Integer

Application.ScreenUpdating = False

Set Sht1 = ActiveWorkbook.Sheets(1)

Set Sht2 = Sheets(2)

Sht2.Activate …清除原有数据

Range("a1").Select

ActiveCell.CurrentRegion.ClearContents

With 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 With

n = 2: m = 2

For x = 1 To 9

For y = 3 To 168 Step 11 …两分表间隔11行

If Sht1.Cells(y, m) <> "" Then …如果姓名值为空，则程序结束

With Sht2

.Cells(n, 2) = Sht1.Cells(y, m)

.Cells(n, 3) = Sht1.Cells(y, m + 2)

.Cells(n, 4) = Sht1.Cells(y, m + 4)

.Cells(n, 5) = Sht1.Cells(y, m + 6)

.Cells(n, 6) = Sht1.Cells(y + 1, m)

.Cells(n, 7) = Sht1.Cells(y + 1, m + 4)

.Cells(n, 8) = Sht1.Cells(y + 3, m)

.Cells(n, 9) = Sht1.Cells(y + 4, m + 4)

End With

n = n + 1

Else

GoTo 100

End If

Next y

'Stop

y = 3: m = m + 9

Next x

100: Range("a1").Select …加编号

n1 = [b65536].End(xlUp).Row

Range("A2").Select

ActiveCell.FormulaR1C1 = "1"

Range("A3").Select

ActiveCell.FormulaR1C1 = "2"

Range("A2:A3").Select

Selection.AutoFill Destination:=Range("A2:A" & n1), Type:=xlFillDefault

Range("A2").Select

Application.ScreenUpdating = True

End Sub

10，筛选尾数

https://www.360docs.net/doc/808768607.html,/dispbbs.asp?boardid=1&id=220360&star=1#220360

Sub weisu()

'筛选尾数0209.xls

'by:Shizx98

'2007-2-9

Dim Myrow1 As Integer

Dim Mymax As Integer

Dim x%, y%, yy%, nn%

Application.ScreenUpdating = False

Range("n1:s30").ClearContents …清除原有数据

Range("a1").Select

Selection.CurrentRegion.Copy Range("b1")

Myrow1 = Selection.CurrentRegion.Rows.Count

Range("c1").Select

Selection.Formula = "=right(rc[-1],4)" ‘取四位尾数

Range("g1").Select

Selection.Formula = "=left(rc[-4],1)" …分成四列

Range("f1").Select

Selection.Formula = "=mid(rc[-3],2,1)"

Range("e1").Select

Selection.Formula = "=mid(rc[-2],3,1)"

Range("d1").Select

Selection.Formula = "=right(rc[-1],1)"

Range("c1:g1").Select

Selection.AutoFill Destination:=Range("c1:g" & Myrow1), Type:=xlFillDefault …公式复制For yy = 2 To 7

Select Case yy

Case 2

Range("h1").Select

Selection.Formula = "=if(and(rc[-4]=rc[-3],rc[-3]=rc[-2],rc[-2]=rc[-1]),1,"""")" …判断四位尾数相等

Selection.AutoFill Destination:=Range("h1:h" & Myrow1), Type:=xlFillDefault

Range("n1") = "尾数四位相同" 'AAAA

Case 3

Range("i1").Select

Selection.Formula = "=if(and(rc[-4]=rc[-3],rc[-3]=rc[-5],rc[-3]<>rc[-2]),1,"""")"

Selection.AutoFill Destination:=Range("i1:i" & Myrow1), Type:=xlFillDefault …判断三位尾数相等

Range("o1") = "尾数三位相同" 'BAAA

Case 4

Range("j1").Select

Selection.Formula = "=if(and(rc[-6]=rc[-5],rc[-5]<>rc[-4],rc[-4]<>rc[-3]),1,"""")" …判断两位尾数相等

Selection.AutoFill Destination:=Range("j1:j" & Myrow1), Type:=xlFillDefault

Range("p1") = "尾数两位相同" 'AA

Case 5

Range("k1").Select

Selection.Formula = "=if(and(rc[-6]=rc[-7],rc[-4]=rc[-5],rc[-5]<>rc[-6]),1,"""")" 'AABB

Selection.AutoFill Destination:=Range("k1:k" & Myrow1), Type:=xlFillDefault

Range("q1") = "尾数AABB"

Case 6

Range("l1").Select

Selection.Formula = "=if(and(rc[-6]=rc[-7],rc[-7]<>rc[-8],rc[-5]=rc[-6]),1,"""")" 'AAAB

Selection.AutoFill Destination:=Range("l1:l" & Myrow1), Type:=xlFillDefault

Range("r1") = "尾数AAAB"

Case 7

Range("m1").Select

Selection.Formula = "=if(and(rc[-9]=rc[-7],rc[-8]=rc[-6],rc[-7]<>rc[-8]),1,"""")" 'ABAB

Selection.AutoFill Destination:=Range("m1:m" & Myrow1), Type:=xlFillDefault

Range("s1") = "尾数ABAB"

End Select

Next yy

Range("c1:m" & Myrow1).Select

Selection.Copy

Range("c1").PasteSpecial Paste:=xlValues '以“选择性粘贴”的“数值”粘贴去除公式影响

500: nn = Myrow1

For y = 1 To 6

n = 2

Mymax = Application.WorksheetFunction.Sum(Range(Cells(1, y + 7), Cells(Myrow1, y + 7)))

If Mymax = 0 Then

GoTo 1000

Else

End If

For x = 1 To nn

If Cells(x, y + 7) = 1 Then

Cells(n, y + 13) = Cells(x, 2)

Range(Cells(x, 2), Cells(x, 13)).Delete shift:=xlUp …有相同的就复制后删除B列的一个，连一行公式数据也删除

n = n + 1: nn = nn - 1

Else

End If

Next x

'Stop

1000: Next y

Range(Cells(1, 3), Cells(Myrow1, 13)).ClearContents

Columns("C:M").Select

Selection.EntireColumn.Hidden = True …隐藏C－M列