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) '背景的颜色蓝色