VBA学习笔记

Sub sss()

Select Case Range(\Case Is = 1

MsgBox \代表入门\Case \

MsgBox (\代表基础\Case \

MsgBox (\代表熟悉\Case \

MsgBox (\代表精通\Case \

MsgBox (\代表专家级\End Select End Sub

Sub save()

Dim iResponse As Integer

iResponse = MsgBox(\If iResponse = vbYes Then

Application.Dialogs(xlDialogSaveAs).Show End If End Sub

Sub been()

Dim icount As Integer

For icount = 10 To 1 Step -2 Beep

MsgBox \Next End Sub

Public Sub ListOfName() Dim i As Integer

Dim iName() As String Dim iCount As Integer Dim iResponse As Integer

iResponse = vbYes

Do While iResponse = vbYes iCount = iCount + 1

ReDim Preserve iName(iCount) As String iName(iCount) = InputBox(\请输入名字:\If iName(iCount) = \

iResponse = MsgBox(\你想继续加入名字吗?\ If iResponse = vbYes Then

iName(iCount) = InputBox(\请输入名字:\ End If End If Loop

For i = 1 To iCount - 1

MsgBox (\Next End Sub

Public Sub ReducePrice() Dim i As Range

For Each i In ThisWorkbook.Worksheets(\i.Value = i.Value - 5 If i.Value <= 0 Then

i.Font.Color = RGB(255, 0, 0) MsgBox \数字小于等于0\ End If Next i End Sub

Public Sub CompareAA() Dim i As Integer Dim j As Integer Dim m As Integer

For i = 2 To Sheets.Count

For j = 4 To Sheets(i).Range(\

m = Sheets(\

If Sheets(i).Cells(j, 6) = Sheets(\).Cells(m, 1) And Sheets(i).Cells(j, 3) = Sheets(\) = Sheets(\Sheets(i).Cells(j, 6).Interior.ColorIndex = 3 Sheets(i).Cells(j, 1).Interior.ColorIndex = 3 Sheets(i).Cells(j, 2).Interior.ColorIndex = 3 Sheets(i).Cells(j, 3).Interior.ColorIndex = 3 Sheets(i).Cells(j, 4).Interior.ColorIndex = 3 Sheets(i).Cells(j, 5).Interior.ColorIndex = 3 End If Next m Next j Next i End Sub

Sub Hebing() Dim i As Integer

For i = 1 To Range(\Application.DisplayAlerts = False

If Cells(i, 6) <> \Range(Cells(i, 8), Cells(i + 1, 8)).Merge Range(Cells(i, 9), Cells(i + 1, 9)).Merge Range(Cells(i, 10), Cells(i + 1, 10)).Merge Range(Cells(i, 11), Cells(i + 1, 11)).Merge Range(Cells(i, 12), Cells(i + 1, 12)).Merge Range(Cells(i, 13), Cells(i + 1, 13)).Merge End If

Application.DisplayAlerts = True Next i End Sub

Sub GetValue()

Dim Sheetname As String Dim i As Integer Dim j As String Dim k As Integer Dim a As Integer

j = Range(\For i = 7 To j

If Cells(i, 4) <> \

Sheetname = Mid(Cells(i, 4), 9, 12) Cells(i, 1) =

Workbooks(ActiveWorkbook.Name).Worksheets(Sheetname).Range(\End If Next

Application.DisplayAlerts = False For k = 7 To j For a = 1 To j - k

If Cells(k, 4) = Cells(k + a, 4) And Cells(k, 4) <> Cells(k + a + 1, 4) Then Range(Cells(k, 1), Cells(k + a, 1)).Merge End If Next Next

Application.DisplayAlerts = True End Sub

Public Sub EnterName() Dim iname As String iname = \

Do While iname = \ If iname = \

iname = MsgBox(\ If iname = vbYes Then

iname = InputBox(\ End If End If Loop End Sub

Sub WorkbookExample()

Dim WorkbookExample As Workbook

Set WorkbookExample = Workbooks.Add // 对象变量一定要用Set WorkbookExample.Worksheets(\WorkbookExample.SaveAs \WorkbookExample.Close End Sub

Sub test()

Dim x As Range

For Each x In ThisWorkbook.Worksheets(\x.Value = x.Value + 10 Next End Sub

Sub BoldEveryOther() Dim iCounter As Integer

For iCounter = 1 To ThisWorkbook.Sheets(\基础数据\Step 2

ThisWorkbook.Sheets(\基础数据\True Next End Sub

Sub SelectRange()

ThisWorkbook.Worksheets(\基础数据\ActiveCell.CurrentRegion.Select

MsgBox \End Sub

Public Sub CompareAA() Dim i As Integer Dim j As Integer Dim m As Integer Dim n As Integer

Dim x As String Dim k As Workbook

x = InputBox(\请输入港盛资料excel表名:\Set k = Workbooks(x)

m = Application.InputBox(\请输入该月起始行号:\n = Application.InputBox(\请输入该月结束行号:\

For i = 7 To k.Worksheets(\船舶明细\For j = m To n

If k.Worksheets(1).Cells(i, 4) = ThisWorkbook.Worksheets(\k.Worksheets(1).Cells(i, 4).Interior.ColorIndex = 4 End If Next j Next i End Sub

关于代码规范:

1. 变量名字前缀,取名字的时候注意可读性 2. 注意代码的位置对齐 3. 注释,这个决定将来维护

Public Sub test()

Dim FileName As String

FileName = Application.GetOpenFilename(\文件,*.xls\If FileName <> \

Workbooks.Open FileName, 0, 1

Range(\0)

ActiveWorkbook.Close 0 End If End Sub

Sub test1()

fileToOpen = Application _

.GetOpenFilename(\If fileToOpen <> False Then MsgBox \End If End Sub

Private Sub CommandButton1_Click() Dim nPath$, nApp

nPath = \ '查询文件路径，自己更新 Set nApp = GetObject(nPath)

nApp.Sheets(1).Range(\nApp.Close

Set nApp = Nothing End Sub

Public Sub MSC()

FileToOpen = Application.GetOpenFilename(\select the files...\If IsArray(FileToOpen) = 0 Then MsgBox \没有选择文件\

MsgBox \End If End Sub

复制未开打文件的内容:

Private Sub test() Dim nPath$, nApp

nPath = \查询文件路径，自己更新 Set nApp = GetObject(nPath)

nApp.Sheets(1).Range(\nApp.Close

Set nApp = Nothing End Sub

获取多个未打开表名和路径

Sub zldccmx() Dim Fp, Dic, Fn

Set Dic = CreateObject(\ Do

Fp = Application.GetOpenFilename(\文件(*.xls), *.xl*\请选择一个目录\

If Fp = False Then Exit Do Fp = Left(Fp, InStrRev(Fp, \ Fn = Dir(Fp & \

Do While Fn <> \ Dic(Fp & Fn) = \ Fn = Dir Loop Loop

If Dic.Count > 0 Then

With Sheets.Add.[a1].Resize(Dic.Count, 1)

.Value = WorksheetFunction.Transpose(Dic.keys) .Sort [a1] End With End If End Sub

Option Explicit

Dim arr(), l As Integer

Function fld(Path As String) Dim fso As Object Dim f As Object Dim fd As Object Dim subf As Object

Set fso = CreateObject(\ Set fd = fso.GetFolder(Path) For Each f In fd.Files l = l + 1

ReDim Preserve arr(1 To l) arr(l) = f.Path Next

For Each subf In fd.SubFolders fld (subf.Path) Next End Function Sub test()

Dim sh As Worksheet, Myname$

Dim brr(1 To 60000, 1 To 5), crr As Variant

Dim n As Integer, i As Integer, j As Integer, wn As String, k As Integer Set sh = ActiveSheet fld ThisWorkbook.Path

Application.ScreenUpdating = False

Sheet6.Range(\ For i = 1 To UBound(arr) Myname = Dir(arr(i))

wn = Replace(Myname, \ If InStr(wn, \结算\

If Myname <> ThisWorkbook.Name Then With GetObject(arr(i))

If .Sheets(\表三甲\

crr = .Sheets(\表三甲\& .Sheets(\表三甲\

For j = 1 To UBound(crr) If crr(j, 1) <> \ n = n + 1

brr(n, 1) = wn: brr(n, 2) = crr(j, 1) For k = 3 To 5

brr(n, k) = crr(j, k) Next End If Next

.Close False End With End If End If nn:

Next

Erase arr l = 0

Sheet6.[a2].Resize(n, 5).Value = brr Application.ScreenUpdating = True End Sub

本文来源：https://www.bwwdw.com/article/rzrx.html