vba案例

市区县分离

Sub 孙1()
  Dim s
  For i = 1 To 56
   Set s = Range("B" & i)
   城市 = InStr(s, "市")
   区县 = InStr(s, "区")
    Range("E" & i) = Left(s, 城市)
    Range("F" & i) = Replace(Left(s, 区县), Left(s, 城市), "")
  Range("G" & i) = Right(s, Len(s) - 区县)
  Next
End Sub

在多个工作簿多个工作表中找到汇总表中缺失的值并进行填充(一次v多列)

Sub shishi()
arr = Range("A1").CurrentRegion
For j = 2 To UBound(arr, 1)
If arr(j, 2) = "" Then
sn = arr(j, 1)
Call 查找(sn, j)
End If
Next
End Sub
Sub 查找(sn, j)
Application.ScreenUpdating = False '屏幕刷新关闭
Set 总表 = ThisWorkbook.Sheets("Sheet1")
Set FSO对象 = CreateObject("Scripting.FileSystemObject")
Set 文件夹 = FSO对象.GetFolder("F:\新建文件夹")
For Each i In 文件夹.Files
Set 工作簿 = Workbooks.Open(i)
For Each 工作表 In 工作簿.Worksheets
Set 结果 = Sheets(工作表.Name).UsedRange.Find(sn)
If Not 结果 Is Nothing Then
地址 = Replace(结果.Address, "$", "")
总表.Range("B" & j) = Sheets(工作表.Name).Range(地址).Offset(0, 1)
总表.Range("C" & j) = Sheets(工作表.Name).Range(地址).Offset(0, 2)
总表.Range("D" & j) = Sheets(工作表.Name).Range(地址).Offset(0, 3)
总表.Range("E" & j) = Sheets(工作表.Name).Range(地址).Offset(0, 4)
总表.Range("F" & j) = Sheets(工作表.Name).Range(地址).Offset(0, 5)
总表.Range("G" & j) = Sheets(工作表.Name).Range(地址).Offset(0, 6)
总表.Range("H" & j) = Sheets(工作表.Name).Range(地址).Offset(0, 7)
GoTo 关闭
End If
Next
关闭: 工作簿.Close 0
Next
Application.ScreenUpdating = True '屏幕刷新关闭
End Sub

在所有表中Vlookup想要的结果

Sub shishi()
Dim I
i= 2
Do While Range("A" & I) <> " "
    单元格 = "C" & I
    Call 查找(Range("A" & I), 单元格)
    i= i+ 1
Loop
End Sub
Sub 查找(形参, 单元格)
For Each 工作表 In Worksheets
    if 工作表.Name <> "总表"     Then
        Set 区域 = Sheets(工作表.Name).Cells.Find(形参)
            If Not 区域 is Nothing Then
            行号 = Mid(区域.Address, InStrRev(区域.Address,"$")+ 1)
            Set 区域2 = Sheets(工作表.Name).Rows(1).Find("分数")
            截取 = Mid(区域2.Address, 2)
            个数 = InStr(截取, "$") -1
            列号 = Mid(截取, 1, 个数)
            Sheets("总表").Range(单元格) = Sheets(工作表.Name).Range(列号 & 行号)
            Exit For
            End If
        End If
    Next
End Sub

不同工作簿的对应工作表的叠加求和

Sub shishi()
Excel.Application.ScreenUpdating = False
Set FSO对象 = CreateObject("Scripting.FileSystemObject")
Set 文件夹 = FSO对象.GetFolder("F:\新建文件夹")
For Each i In 文件夹.Files
    Set 工作簿 = Workbooks.Open(i)
    For Each sh In 工作簿.Worksheets
        Set 工作表 = 工作簿.Worksheets(sh.Name)
        Set 合并表 = ThisWorkbook.Worksheets(sh.Name)
        工作表.Range("A1").CurrentRegion.Copy
        合并表.Range("A1").PasteSpecial xlPasteAll, xlPasteSpecialoprationadd
        Next
    工作簿.Close
Next
Excel.Application.ScreenUpdating = True
 End Sub

季度汇总

Sub 季度汇总()
Dim i, k, name
Dim w As Worksheet, r As Worksheet
Set r = Worksheets("季度汇总")
'循环扫描汇总表中的每一行，记住每次要查找的姓名
For i = 3 To 10
        name = r.Cells(i, 2)
    '循环扫描所有工作表，并用 w 指向该工作表
        For Each w In Worksheets
        '如果该工作表名字以“月”结尾，则认为是月报表
            If Right(w.name, 1) = "月" Then
            '循环扫描该月报表的每一行，判断其姓名列是否等于name
                k = 3
                Do While w.Cells(k, 2) <> ""
            '如果第k行姓名等于Name，则将该行累加到汇总表第i行
                    If LCase(Trim(w.Cells(k, 2))) = LCase(Trim(name)) Then
                        '以下四行代码可以用循环的方式改写，更加方便
                        r.Cells(i, 3) = r.Cells(i, 3) + w.Cells(k, 3)
                        r.Cells(i, 4) = r.Cells(i, 4) + w.Cells(k, 4)
                        r.Cells(i, 5) = r.Cells(i, 5) + w.Cells(k, 5)
                        r.Cells(i, 6) = r.Cells(i, 6) + w.Cells(k, 6)
                    End If
                    k = k + 1
                Loop
            End If
        Next w
Next i
End Sub

九九乘法表

Sub 九九乘法表()
Dim a, b
For a = 1 To 9
    For b = 1 To 9
    If a < b Then
        Cells(a + 1, b) = ""
    Else
        Cells(a + 1, b) = a & "x" & b & "=" & a * b
    End If
    Next
Next
End Sub

求平均分()

Sub 平均分()
Dim i, 总分, 计数
总分 = 0
计数 = 0
i = 2
Do While Cells(i, 1) <> ""
总分 = 总分 + Cells(i, 2)
计数 = 计数 + 1
i = i + 1
Loop
If 计数 > 0 Then
Cells(4, 4) = Int(总分 / 计数)
End If
End Sub

生日函数

Function 生日(x)
生日 = DateSerial(Mid(x, 7, 4), Mid(x, 11, 2), Mid(x, 13, 2))
End Function

删除当前工作表中的所有形状：

Sub DeleteAllShapesInWorksheet()
Dim shp As Shape
For Each shp InActiveSheet.Shapes
shp.Delete
Next shp
End Sub

下面的代码删除指定类型形状（图表和单元格批注）
之外的所有形状：

Sub 删除指定类型形状()
    Dim shp As Shape
For Each shp InActiveSheet.Shapes
    If shp.Type <>msoChart And shp.Type <> msoComment Then
        '删除图标和批注
        shp.Delete
    End If
Next shp
End Sub