VBA 入门进阶 实用小程序

这些都是平时用到的小程序，涉及到知识点的都总结下来了，主要包括循环的利用，文件读写，学会了很简单，只要把逻辑整理清楚就好。

最复杂的是没有规律的Excel文档，这个最让人头疼。。

--------------------------------------------------------------------------------------------------------------------

'取出所有页签名字
Sub foreachnext循环2()
Dim wsht As Worksheet, n As Byte, s As String
For Each wsht In Worksheets
    n = n + 1
    Sheet1.Cells(n, 9) = wsht.Name
    Next
End Sub


'用于统计所有的页签数以及页签名称，带指针
'执行之前要先放在第一个页签，显示结果是Sheet1的A1-An
Private Sub Workbook_Open()
a = ThisWorkbook.Sheets.Count
For i = 1 To a
Sheets(1).Cells(i, 1) = Sheets(i).Name
Sheets(1).Hyperlinks.Add Anchor:=Sheets(1).Cells(i, 1), Address:="", SubAddress:= _
        Sheets(i).Name & "!A1", TextToDisplay:=Sheets(i).Name
Next
End Sub


'删除空行 500行以前的，效率慢，慎太多
Sub DeleteBlank()
    Dim i As Long
    For i = 550 To 1 Step -1
        If Cells(i, 2) <> "Currency keys of policy template are inconsistent" Then
            Cells(i, 2).EntireRow.Delete
        End If
    Next
        
End Sub


'删除不包含“张”的行
'InStr函数返回第二个字符串出现在第一个字符串的位置n，不包含返回0
Sub DeleteZhang()
    Dim i As Long
    For i = 34 To 1 Step -1
        If Cells(i, 1).Value Like "张" Then
            i = i - 1
        Else
        Cells(i, 1).EntireRow.Delete
        End If
    Next
End Sub
'
' 删除单元格前后的空格
' Delete spaces in the front/end of a cell(in column)
Sub deleteSpaces()
    ActiveCell.Offset(0, 11).Range("A1").Select
    ActiveCell.FormulaR1C1 = "=TRIM(RC[-11])"
    ActiveCell.Select
    Selection.AutoFill Destination:=ActiveCell.Range("A1:A5"), Type:= _
        xlFillDefault
    ActiveCell.Range("A1:A5").Select
    ActiveCell.Columns("A:A").EntireColumn.Select
    Selection.Copy
    ActiveCell.Offset(0, -11).Columns("A:A").EntireColumn.Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    ActiveCell.Offset(0, 11).Columns("A:A").EntireColumn.Select
    Application.CutCopyMode = False
    Selection.ClearContents
    ActiveCell.Offset(0, -11).Columns("A:A").EntireColumn.Select
End Sub


'判断两块儿的数据是否完全相同
'Goto语句的使用
Sub JudgeAllSame()
Dim i!, j!
i = 1
j = 1
Do While i < 4
    j = 1
    Do While j < 24
    If Cells(j, i) <> Cells(j + 23, i) Then
        GoTo Line1
    End If
    j = j + 1
    Loop
    i = i + 1
Loop
Line1:
If i = 4 Then
    MsgBox ("same  " & j & "," & i)
End If
End Sub


'三重循环
Sub PDEP()
Dim n!, m!
m = 3000
For i = 1 To m
    If InStr(Cells(i, 1), "PD_") = 1 Then
        Cells(i, 1).Interior.ColorIndex = 7
        n = 1
        While InStr(Cells(i + n, 1), "PD_") <> 1
            Cells(i, 1 + n) = Cells(i + n, 1)
            n = n + 1
            If n = m Then Cells(i + n, 1) = "PD_"
        Wend
    End If
Next i


For j = m To 1 Step -1
    If InStr(Cells(j, 1), "PD_") <> 1 Then Cells(j, 1).EntireRow.Delete
Next j


End Sub


'比较两列是否存在包含关系
Sub Match()
Dim m!, n!
m = 400
n = 0
For i = 215 To m
    n = 132
    Do While n <= m
        If Cells(i, 3) Like "*" & Cells(n, 2) & "*" Then
            Cells(i, 4) = Cells(n, 1)
            Exit Do
        End If
        n = n + 1
    Loop
Next i


End Sub


'整块数据复制
Sub CopyPDAndEP()
Dim i#, j#
Dim n#
Dim rng As Range
Dim myrng As Range
Dim flag#
i = 1
j = 1
flag = 0
For i = 2 To 8666
    n = 0
    flag = 0
    For j = 1 To 450
        n = 0
        If Sheets("S-P-P").Cells(i, 4) = Sheets("SPE").Cells(j, 1) And Sheets("S-P-P").Cells(i, 4) <> "" Then
            flag = 1
            Do While Sheets("SPE").Cells(j + n + 1, 1) = "" And j + n + 1 < 452
                n = n + 1
            Loop
            Set myrng = Sheets("SPE").Range("B" & j & ":C" & j + n)
            Sheets("S-P-P").Range("E" & i & ":F" & i + n).Value = myrng.Value
            Exit For
        End If
    Next j
    If flag = 0 And Sheets("S-P-P").Cells(i, 4) <> "" Then
         Sheets("S-P-P").Cells(i, 5).Interior.Color = RGB(0, 100, 255)
    End If
Next i
End Sub


'纵向合并单元格
Sub HeBing()
Application.DisplayAlerts = False
    Dim i As Integer
    Dim flag As Integer
    Dim first As Integer
    Dim last As Integer
    first = 1
    last = 1
    For i = 1 To 4000 Step 1
        
        If Worksheets("S-P-P").Range("F" & i) <> Worksheets("S-P-P").Range("F" & i + 1) Then
            
            '在遇到非空值时合并上面的
            Worksheets("S-P-P").Range("F" & first & ":F" & last).Select
            With Selection
            .MergeCells = True
            End With


            first = i + 1
            last = i + 1
        Else
            last = last + 1
        End If
Next
Application.DisplayAlerts = True
End Sub


'标记出找不到的SP
Sub MarkSPCannotfind()
Dim i#, j#
i = 1
j = 1
For j = 1 To 3500
    If Sheets("SPE").UsedRange.Find(Sheets("S-P-P").Cells(j, 4)) Is Nothing Then
        Sheets("S-P-P").Cells(j, 7).Interior.Color = RGB(0, 255, 0)
    End If
Next j
End Sub


'把含有换行chr(10)的单元格从上向下分割为多个单元格
Sub DivideSP()
Worksheets("S-P-P").Select
Dim i#, j#, l#, str$, aa, k#


For j = 1 To 5000
    str = Cells(j, 4).Value
    l = Len(str) - Len(Replace(str, Chr(10), ""))
    If l > 0 Then
        
        '检测到chr(10)换行后，在当前行下方插入一行，并将当前行复制到新增的行
        For i = 1 To l
            Cells(j + 1, 1).EntireRow.Insert Shift:=xlDown
            Rows(j).Copy Cells(j + 1, 1)
        Next i
        
        'aa是一个字符串数组，直接得到用chr(10)分割后的所有字符串
        aa = Split(str, Chr(10))
        For k = 0 To UBound(aa)
            Cells(j + k, 4) = aa(k)
        Next k
        
        j = j + i - 1
    End If
Next j
End Sub
'写文件，涉及到双引号、回车的写入，以及长文本换行
 Private Sub CWriteFile()
    Dim gPath As String
    Dim sFile As Object, Fso As Object
    Dim i%
    i = 2
    gPath = Application.ActiveWorkbook.Path
    Set Fso = CreateObject("Scripting.FileSystemObject")
    Set sFile = Fso.CreatetextFile(gPath & "/TestFile.vbs", True)
    
    sFile.WriteLine ("If Not IsObject(application) Then" + vbCrLf + _
            "Set SapGuiAuto = GetObject(""SAPGUI"")" + vbCrLf + _
            "Set application = SapGuiAuto.GetScriptingEngine " + vbCrLf + _
            "End If " + vbCrLf + _
            "If Not IsObject(Connection) Then " + vbCrLf + _
               "Set Connection = Application.Children(0) " + vbCrLf + _
            "End If " + vbCrLf + _
            "If Not IsObject(Session) Then" + vbCrLf + _
               "Set Session = Connection.Children(0) " + vbCrLf + _
            "End If " + vbCrLf + _
            "If IsObject(WScript) Then" + vbCrLf + _
               "WScript.ConnectObject Session, ""on""" + vbCrLf + _
               "WScript.ConnectObject Application, ""on"" " + vbCrLf + _
            "End If " + vbCrLf + _
            "Session.findById(""wnd[0]"").maximize " + vbCrLf + _
            "Session.findById(""wnd[0]/tbar[0]/okcd"").text = ""/NLT01"" " + vbCrLf + _
            "Session.findById(""wnd[0]"").sendVKey 0 " + vbCrLf + _
            "Session.findById(""wnd[0]/usr/ctxtLTAK-LGNUM"").text = ""SU1"" " + vbCrLf + _
            "Session.findById(""wnd[0]/usr/ctxtLTAK-BWLVS"").text = ""998"" " _
            )
    
    Do While Sheets("Sheet1").Cells(i, 1) <> ""
        sFile.WriteLine ("session.findById(""wnd[0]/usr/ctxtLTAP-MATNR"").text = " & Chr(34) & Sheets("Sheet1").Cells(i, 1).Value & Chr(34))
        sFile.WriteLine ("session.findById(""wnd[0]"").sendVKey 0")
        i = i + 1
    Loop
    sFile.Close
    Set sFile = Nothing
    Set Fso = Nothing
End Sub




Cells(1, 1).Font.ColorIndex = 3 '字的颜色号为3 红色
Cells(1, 1).Interior.ColorIndex = 3 ' 背景的颜色为3 红色
Cells(2, 1).Font.Color = RGB(0, 255, 0) '字的颜色绿色
Cells(2, 1).Interior.Color = RGB(0, 0, 255) '背景的颜色蓝色