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.Value
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
'以“选择性粘贴”的“数值”粘贴
- 1
- 2
- 3
前往页