日期递增代码
Sub 日期递增代码()
Dim i As Variant
For i = 2 To 31
Worksheets(i).[a1] = Worksheets(1).Range("a1").Value + i - 1
Next
End Sub

生成工作表
复制内容
Sub 生成工作表()
Dim i%
For i = 1 To 28
Sheets.Add After:=Sheets(Sheets.Count) '在sheet3后面新建28个sheets
Next
End Sub
Sub 复制工作表内容()
For i = 3 To 31
Sheets("Sheet2").Select
Cells.Select
Selection.Copy
Worksheets(i).Select '把sheet2的内容复制到 sheet3:31
Range("A1").Select
ActiveSheet.Paste
Next
End Sub

正则表达式

Sub df()
Dim regEX As New RegExp '定义一个正则表达式对象
regEX.Pattern = "\((\d{3,4})\)(\d{7,8})" '设置正则表达式
For i = 1 To 14
Range("c" & i) = regEX.Replace(Range("a" & i), "$1-$2")
Next
End Sub

Sub 工作表合并()
For Each st In Worksheets
If st.Name <> ActiveSheet.Name Then
st.UsedRange.Offset(1, 0).Copy [a65536].End(xlUp).Offset(1, 0)
End If
Next
End Sub

正则表达式的三种用法
-----------------------------------------------------------------------------
Sub 替换()
Set regx = CreateObject("vbscript.regexp")
With regx
.Global = True
.Pattern = "\D"
For Each Rng In [a1:a4]
Cells(Rng.Row, 2) = .Replace(Rng, "")
Next
End With
End Sub
-----------------------------------------------------------------------------
Sub 提取()
Set regx = CreateObject("vbscript.regexp")
With regx
.Global = True
.Pattern = "\S+"
For Each Rng In [b1:b4]
Set mat = .Execute(Rng)
For Each m In mat
y = y + 1
Cells(Rng.Row, y + 2) = m '将匹配的内容依次存放在数据单元格后面
Next
y = 0
Next
End With
End Sub
-----------------------------------------------------------------------------
Sub 验证()
Set regx = CreateObject("vbscript.regexp")
With regx
.Global = True
.Pattern = "abc|abb\b"
For Each Rng In [b2:b10]
If .Test(Rng) Then
n = n + 1
Cells(n + 1, "d") = Cells(Rng.Row, 1) '将匹配成功的A列的内容放到D列
End If
Next
End With
End Sub
-----------------------------------------------------------------------------

筛选重复与不重复的数据
Sub 筛选数据()
t = [a1].End(xlDown).Row
Set arr = Range("a1:a" & t)
For Each m In arr
For Each n In arr
a = m.Value
b = n.Value
If a = b Then
k = k + 1
End If
Next
If k = 1 Then
i = i + 1
Cells(i, "F") = a '将不重复的数据放在F列
Else
q = q + 1
Cells(q, "G") = a '将重复的数据放在G列
End If
k = 0
Next
r = [g1].End(xlDown).Row
Range("g1:g" & r).RemoveDuplicates Columns:=1, Header:=xlNo '删除重复项
End Sub

分组提取
------------------------------------------------
Sub 分组提取提取()
Set regx = CreateObject("vbscript.regexp")
With regx
.Global = True
.Pattern = "颜色分类：(.+)；尺码：(.+)；"
For Each Rng In [a1:a11]
Set mat = .Execute(Rng)
For Each m In mat
a = .Replace(m, "$1")
b = .Replace(m, "$2")
Rng.Offset(0, 1) = a & "_" & b
Next
Next
End With
End Sub
--------------------------------------------

字典技术
Sub first()
Dim arr()
On Error Resume Next
Set d = CreateObject("scripting.dictionary")
x = [b9999].End(xlUp).Row
arr = Range("b2:c" & x)
For i = 1 To UBound(arr)
d.Add arr(i, 1), arr(i, 2) '把数据写入字典 常规写法
Next
[f2].Resize(d.Count) = Application.Transpose(d.keys)
[g2].Resize(d.Count) = Application.Transpose(d.items)
End Sub
Sub last()
Dim arr()
On Error Resume Next
Set d = CreateObject("scripting.dictionary")
x = [b9999].End(xlUp).Row
arr = Range("b2:c" & x)
For i = 1 To UBound(arr)
d(arr(i, 1)) = arr(i, 2) 'd(key)=item 如果没有这个key就增加 有就覆盖
Next
[j2].Resize(d.Count) = Application.Transpose(d.keys)
[k2].Resize(d.Count) = Application.Transpose(d.items)
End Sub

Sub 字典提取不重复值()
Dim arr()
On Error Resume Next
Set d = CreateObject("scripting.dictionary")
x = [b9999].End(xlUp).Row
arr = Range("b2:b" & x)
For Each Rng In arr
d(Rng) = ""
Next
[n2].Resize(d.Count) = Application.Transpose(d.keys)
End Sub
提取B列不重复值到n列

Sub 汇总回抄()
For Each st In Worksheets
If st.Name <> "sheet32" Then
ActiveWindow.ScrollWorkbookTabs Position:=xlFirst
st.Select
ActiveWorkbook.RunAutoMacros Which:=xlAutoActivate
Range("G9", [h30].End(3).Offset(1, 0)).Select
Selection.Copy
ActiveWindow.ScrollWorkbookTabs Position:=xlLast
Sheets("Sheet32").Select
[a1000].End(3).Offset(1, 0).Select
ActiveSheet.Paste
End If
Next
End Sub
汇总回抄吨数

水分偏差
Sub water()
For Each wb In Workbooks
wb.Activate
For Each wk In Worksheets
wk.Activate
If [a2].Value Like "*甲*" Then
For Each Rng In [f24:z24]
x = Rng.Value
If x > 0 And x <= 1.5 Then
jia1 = jia1 + 1
ElseIf x > 1.5 And x <= 2 Then
jia2 = jia2 + 1
ElseIf x > 2.5 Then
jia3 = jia3 + 1
End If
Next
ElseIf [a2].Value Like "*乙*" Then
For Each Rng In [f24:z24]
x = Rng.Value
If x > 0 And x <= 1.5 Then
yi1 = yi1 + 1
ElseIf x > 1.5 And x <= 2 Then
yi2 = yi2 + 1
ElseIf x > 2.5 Then
yi3 = yi3 + 1
End If
Next
ElseIf [a2].Value Like "*丙*" Then
For Each Rng In [f24:z24]
x = Rng.Value
If x > 0 And x <= 1.5 Then
bing1 = bing1 + 1
ElseIf x > 1.5 And x <= 2 Then
bing2 = bing2 + 1
ElseIf x > 2.5 Then
bing3 = bing3 + 1
End If
Next
End If
Next
Next
MsgBox "甲班奖励 5元个数为 " & jia1
MsgBox "甲班奖励 2元个数为 " & jia2
MsgBox "甲班扣罚10元个数为 " & jia3
MsgBox "甲班水分偏差奖励钱数为 " & jia1 * 5 + jia2 * 2 - jia3 * 10
MsgBox "乙班奖励 5元个数为 " & yi1
MsgBox "乙班奖励 2元个数为 " & yi2
MsgBox "乙班扣罚10元个数为 " & yi3
MsgBox "乙班水分偏差奖励钱数为 " & yi1 * 5 + yi2 * 2 - yi3 * 10
MsgBox "丙班奖励 5元个数为 " & bing1
MsgBox "丙班奖励 2元个数为 " & bing2
MsgBox "丙班扣罚10元个数为 " & bing3
MsgBox "丙班水分偏差奖励钱数为 " & bing1 * 5 + bing2 * 2 - bing3 * 10
End Sub

Sub water()
ss = InputBox(输入需查询关键字)
For Each wk In Worksheets
wk.Activate
If [b12].Value Like "*" & ss & "*" Then
MsgBox wk.Name
End If
Next
MsgBox ("搜索完毕")
End Sub