VBA学习

基础

学习资料

《[Excel.VBA常用代码实战大全].袁竹平.扫描版》

代码地址1：https://github.com/frankzheng43/-VBA-in-practice

代码地址2：https://github.com/teishorinchina/VBA_test_code

打开方法

打开：ALT+F11 ；工具-宏-vb编辑器

F5运行，F8下一步

右键单击工作表标签，执行【查看代码】菜单命令

单击【Visual Basic】工具栏中的【Visual Basic编辑器】按钮。

控件工具箱

过程

因为VBA程序一般保存在模块里，所以在编写程序前，应先添加一个模块来保存它 Public Sub mysub() MsgBox "sereny welcomde" End Sub

F5保存后运行

数据类型

commonly used built-in data types: Integer, Long, Single, Double, Boolean, String

Integer 2 byte 
integer Long 4 byte 
integer Single 4 byte 
floating point (Real) 
Double 8 byte 
floating point (Real) 
Currency 8 byte real 
String up to 64K 
characters Byte 1 byte 
Boolean 2 byte true or false 
Date 8 bytes 
Object 4 bytes – an object reference 
Variant 16 bytes + 1 byte / character

 

实现菜单栏管理与自定义菜单栏功能

https://blog.csdn.net/majinggogogo/article/details/10472595

在 VBA 中皆用 CommandBar 对象表示：在 VBA 和 Microsoft Visual Basic 中，按钮和菜单项用 CommandBarButton 对象表示。显示菜单和子菜单的弹出控件用 CommandBarPopup 对象表示。在以下示例中，名为“Menu”的控件和名为“Submenu”的控件都是用于显示菜单和子菜单的弹出控件，并且这两个控件是各自的控件集中唯一的 CommandBar 对象。

杂

运行时错误91 vba

ActiveWindow.Caption = ""

没有 ActiveWindow

声明一个Worksheet对象变量和分配给它。

 

没有工作表

文件-选项-高级-此工作簿显示选项-显示工作表标签

报错，说endif没有if'块缺少End With

cbxMc.AddItem .Cells(i, 3) 'ad 要有个空格

代码listbox

listbox1.additem .cells(i,3) 在列表框listbox1中新增一行，该行第一列的值是sheets("图书资料")第i行，第3列的单元格值 listbox1.list(listbox1.listcount-1,1)= .cells(i,1) 在列表框listbox1中新增的那一行的第二列赋值为sheets("图书资料")第i行，第1列的单元格值

SumProduct

=SUMPRODUCT(E2:E16,F2:F16)

乘积+求和的功能正是SUMPRODUCT所专职扮演的，个参数的逐个元素依次相乘，最后将各个乘积的结果求和。

=E2*F2+E3*F3+E4*F4....E16*F16

Round

在VBA中Round函数是采用“银行家舍入”,

BA内置的Round函数在对数值进行四舍五入运算时实行的就是Bankre舍入，而不是算术舍入。按Bankre舍入规则，如果保留位数的下一个数字正好是5则其后没有其他有效数字，则按保留位最后一位“偶舍奇入”的方法进行处理。

　　要对A进行四舍五入，保留B位小数，Round(A 0.1^(B 2),B)

清除

     With Worksheets("Sheet1")
         .Range(.Cells(2, 1), .Cells(1048576, 16384)).ClearContents
     End With

ClearContents是只清除内容的,不清除格式

排序

Range("a1:a10").Sort Key1:=Range("a1"), Order:=xlAscEnding 语句中“:=" 是什么含义

通常VBA参数的书写是有先后顺序的,用了:=后参数就可以不按先后顺序书写了,方便编写的人。

Range("a1:a10").Sort Order:=xlAscEnding ,Key1:=Range("a1")

 比如Order和key1是sort 方法的属性。也就是排序时的关键字等相关的参数。

单元格

D5:

ActiveSheet.Cells(5, 4).Select 或:ActiveSheet.Range("D5").

A5 .Cells(5,1).

cstr

Cstr() 意思将括号内的数据转换为文本型

宏被禁止----- 解决办法

Office按钮, 右下角"excel 选项" ==>信任中心 ==>信任中心设置 ===>宏设置==> 设置成限制最小. 然后重新打开excel, 再试试vba, 发现就可以运行了. 但是注意安全性.

1. 有人建议, 不要将常用vba存在每个excel的modle中, 存放在personal files中. 这样可以在各个excel中引用/运行.

#1219

Option Explicit 语句在模块级别中使用，强制显示声明模块中的所有变量。 如果模块中使用了 Option Explicit， 则必须使用 Dim、Private、Public、ReDim 或 Static 语句来显式声明所有的变量

xlformatfromleftorabove

这就是要按填充方向来决定选择哪个： 　向右填充时，从左边的单元格复制格式。 　向下填充时，从上边的单元格复制格式

粘贴

Selection.PasteSpecial Paste:=xlValues, Operation:=xlNone, SkipBlanks:= _ False, Transpose:=False

上面语句的含义是：对选择的内容（Selection），执行PasteSpecial操作（选择性粘贴），粘贴的方式为数值，且不进行运算，不跳过空单元格，不转置，可参考选择性粘贴窗口的各个选项。

Application.CutCopyMode=false作用

在复制或者剪切了大量内容后关闭文件,如果不写上这句代码, 1、会出现提示窗口:是否保存手复制的内容到剪贴板,以便下次使用

单元格表示

Range("B10").End(xlUp)表示的就是在B列从第10行(不包含第10行)向上查找到的第一个有数据的单元格.

R2C3表示位于第2行、第3列的单元格

RC[-1],R[-1]C[-1]都是R1C1的单元格引用格式

R[-1]C 对当前单元格所在列中的上一行单元格的相对引用，即D4单元格。 R[5]C[2] 对当前单元格下面第5行、右面第2列的单元格的相对引用，即F10单元格。 R5C2 对当前工作表的第5行、第2列的单元格的绝对引用，相当于​5。 R[-1] 对当前单元格上面一行区域的相对引用，相当于4:4。 R 对当前行的绝对引用，相当于​5

简单代码例子

小的

考试成绩，计算体积，生日计算

计算平均成绩，计算年龄升序

冒泡排序,浮点数对比，回复yes

Range("J3:K3").Select

 

分年纪

一个学期参加青年阶段1课程，然后下个学期，他们的孩子会自动移动 提升水平尽管这是不正确的，因为要完成进度需要完成8个关键目标。 如果孩子不能将所有目标都达到令人满意的水平，则他们必须保持在该水平。

。如果孩子在该阶段完成了所有复选框，则他们 可以进入下一个阶段。但是，如果一切还没有完成，那么他们 必须在另一个任期内保持相同水平。对于此应用程序，仅青年阶段1，

 

日历

多个端的

A1输入100

Application.Worksheets( “ Sheet1 “ ).Range( “ A1 “ ).Value = 100

Application 代表 Excel 应用程序

Workbook 代表 Excel 中的工作簿，一个 Workbook 对象代表一个工作簿文件

Range 代表 Excel 中的单元格，可以是单个单元格，也可以是单元格区域

参考代码

 # ‘MsgBox
 Part = MsgBox("Please choose your part. Click Yes when", vbYesNoCancel, "Part of the module")

猜数字

www.johnsmith.co.uk/soton

 Dim x 
 is equivalent to 
 Dim x As Variant
 ​
 Dim sheet As s1
 ​

 

Example

 Sub ShowDiscount()
     Dim Price As Integer
     Dim Discount As Double
      Price = InputBox("Enter  Price:  ")
     Select Case Price
         Case 0 To 24
             Discount = 0.1
         Case 25 To 49
             Discount = 0.15
         Case 50 To 74
             Discount = 0.2
         Case Is >= 75
             Discount = 0.25
     End Select
     MsgBox "Discount: " & Discount
 End Sub

for_next

 Private Sub ShadeofGreyEveryOtherRow()
     Dim i As Long
     For i = 1 To 300 Step 2
     Rows(i).Interior.Color = RGB(200, 200, 200)
     Next i
 End Sub

do-while-loop

 Dim lngCount As Long
         lngCount = 1
           Do While lngCount <= 10
         MsgBox CStr(lngCount)
         lngCount = lngCount + 1 
 Loop

do-while until

 'Repeat the code while the condition is true
     Do While i <= 10
         your code
     Loop
 OR
 ​
     Do
         your code
     Loop While i <= 10
 ​
 'Repeat the code while the condition is false = until the condition becomes true
 ​
     Do until i > 10
         your code
     Loop
 OR
 ​
     Do
         your code
     Loop Until i > 10
 ​

程序

 Private Function HasPassed( _
     ByVal lngPassedCourses As Long, _
     ByVal dblAverage As Double) As Boolean
     
     HasPassed = False
     If lngPassedCourses < 4 Then
         Exit Function
     End If
     If (lngPassedCourses < 6) And (dblAverage < 45.5) Then
         Exit Function
     End If
     HasPassed = True
 End Function

 ​

excel

3

 Sub StatementsExample()
 Dim Surname As String
 Dim Forname As String
 Surname = InputBox("What is your surname name?")
 Forename = InputBox("What is your forename name?")
 MsgBox ("I'm an oracle! Your name is " & Forename & " " & Surname)
 End Sub
 Private Sub A()
   Dim strInput As String
   Dim lngSqr As Long
   
   strInput = "9.1"
   lngSqr = strInput * strInput
   MsgBox lngSqr
 End Sub
 Private Sub B()
   Dim strInput As String
   Dim lngAge As Long
   Dim lngSqr As Long
   
   strInput = "9.1"
   lngAge = CLng(strInput)
   lngSqr = lngAge * lngAge
   MsgBox CStr(lngSqr)
 End Sub
 ​

4

 Private Sub AnnoyUser()
     Dim Response As VbMsgBoxResult
         Do
         Response = MsgBox("Hi, I would like to state your name. Is your name John?", vbYesNo)
         Loop Until Response = vbYes
     MsgBox "See... I knew your name was John!?"
 End Sub
 ‘vb
 Sub NumberIsGreaterThan1()
 Dim lngNumber As Long
 lngNumber = InputBox("Input an integer of your choice")
 If lngNumber < 0 Then
         MsgBox "Number is less than 0?"
     ElseIf 0 <= lngNumber And lngNumber <= 1 Then
         MsgBox "Number between 0 and 1, inclusive"
     Else
         MsgBox "Number is greater than 1?"
 End If
 End Sub
 ‘颜色
 Private Sub ShadeofGreyEveryOtherRow()
 Dim i As Long
 For i = 1 To 300 Step 2
 Rows(i).Interior.Color = RGB(200, 200, 200)
 Next i
 End Sub
 ‘计算打折价格
 Sub ShowDiscount()
     Dim Price As Integer
     Dim Discount As Double
      Price = InputBox("Enter  Price:  ")
     Select Case Price
         Case 0 To 24
             Discount = 0.1
         Case 25 To 49
             Discount = 0.15
         Case 50 To 74
             Discount = 0.2
         Case Is >= 75
             Discount = 0.25
     End Select
     MsgBox "Discount: " & Discount
 End Sub
 ’先判断再决定酒吧
 Option Explicit
 Sub ShowUsYourAge()
 Dim strAge As String
 Dim dblAge As Double
 Dim strDrink As String
 ​
 strAge = InputBox("What is your age in years?")
 dblAge = CDbl(strAge)
     If dblAge < 16 Then
         GoTo Underage:
     Else
         GoTo Whatsyourtipple:
     End If
 ​
 'Goto statements are below:
 Underage:
       MsgBox ("You are not old enough to drink. Please leave now")
 End
 ​
 Whatsyourtipple:
   strDrink = InputBox("What can I get you?")
     MsgBox (strDrink & " coming up!")
 End
 End Sub
 ​
 ‘比赛计分比较
 ​
 'The following sub demonstrates nested loops, i.e. a loop within a loop
 'First loop asks user to enter a Amount and if answer is no exits the loop
 'Second loop is nesed within the first loop usind Do...until this loop asks user to keep entering values until user says no.
 ​
 Sub CompareFootballScores()
   Dim Team1Score As Long
   Dim Team2Score As Long
   Dim Relst As String
   Dim Response As VbMsgBoxResult
   Dim Response2 As VbMsgBoxResult
     
 Response = MsgBox("This routine compares the scores of two football teams. Would you like to enter scores to compute the results?", vbYesNo, "Initial Amount Entry")
 ​
 Do While Response = vbYes                    'Loop 1 starts here
 ​
     Do                                       'Loop 2, which is inside loop 1 starts, here ****.
         Team1Score = InputBox("Enter Team A score: ")
         Team2Score = InputBox("Enter Team B score: ")
             If Team1Score > Team2Score Then
             Result = "Team A won " & Team1Score & "-" & Team2Score
             ElseIf Team2Score > Team1Score Then
             Result = "Team B won " & Team2Score & "-" & Team1Score
             Else
             Result = "The match was drawn " & Team2Score & " all"
             End If
         MsgBox Result
         Response2 = MsgBox("Would you like to enter more scores to compare?", vbYesNo, "Subsquent Amount Entry")
     Loop Until Response2 = vbNo
     Exit Do                                 'Loop 2 ends here. 'Exit do' is required to stop it ****
                                 
 ​
 Loop                                        'End of loop 1
 End Sub
 ​
 #计算年龄
 Option Explicit
 Dim myDOB As Date
 Private Function MyAge(ByVal myDOB As Date) As Double
     MyAge = FormatNumber((Date - myDOB) / 365.25, 2)
 End Function
 ​
 Private Sub ShowAge()
 Dim strAge As String
     
     'Allow entry as a string for a little bit of flexibility
     strAge = InputBox("What is your date of birth in dd/mm/yyyy format?", "Enter Date of Birth")
     'Convert string into date value
      
      myDOB = CDate(strAge)
         
     'Now call the function has MyAge and display the age
     
     MsgBox "Your age is " & MyAge(myDOB) & " years."
 ​
 End Sub
 ​

各种基础

 Option Explicit
 '类型
 Private Type Student                                                                                        'Declare UDT called student
     Name As String                                                                                          'Notice the Type declaration is at the topic of the module, outside of any subs; this give it file scope
     Age As Long
     Height As Double
     Course As String
 End Type
 ​
 Private Const lngNUMBERSTUDENTS = 4                                                                         'Declare a constant for the number of students; this allows us to run the same program easily with a different number of students other than 4
 '------------------------------------------------------------------------------------
 ' Name: BubbleSortAscendingByAge
 ' Description: Bubble sort algorithm to sort students in ascending order by age and display the result.
 '------------------------------------------------------------------------------------
 Private Sub BubbleSortAscendingByAge()
     Dim ArrayUdtStudent(1 To lngNUMBERSTUDENTS) As Student                                                  'Declare an array, which contains data of the type student (cf. you could declared an array of double, string, or any other type; it just happens that the type in this case is UDT)
     Dim OuterLoopIndex As Long                                                                              'OuterLoopIndex  and InnerLoopIndex  are variables to represent index numbers the array ArrayUdtStudent
     Dim UdtTempStudent As Student                                                                           'Declare a variable of the UDT type student to temporarily hold data when values are swapped
     Dim strOutput As String
 ​
     ' Populate the student array somehow
     ArrayUdtStudent(1).Name = "Paul"
     ArrayUdtStudent(1).Age = 21
     ArrayUdtStudent(1).Height = 1.84
     ArrayUdtStudent(1).Course = "Accounting"
     With ArrayUdtStudent(2)                                                                                 'Recall this structure leads to the same output as above regarding student names
         .Name = "Liz"
         .Age = 18
         .Height = 1.52
         .Course = "Business Analytics"
     End With
     With ArrayUdtStudent(3)
         .Name = "Kate"
         .Age = 20
         .Height = 1.7
         .Course = "Accounting and Finance"
     End With
     With ArrayUdtStudent(4)
         .Name = "Jonathan"
         .Age = 19
         .Height = 1.72
         .Course = "Business Management"
     End With
     
     'Bubble sort algorithm
     For OuterLoopIndex = 1 To lngNUMBERSTUDENTS
         For InnerLoopIndex = 1 To lngNUMBERSTUDENTS - 1
             If ArrayUdtStudent(InnerLoopIndex).Age > ArrayUdtStudent(InnerLoopIndex + 1).Age Then           'If current student InnerLoopIndex  age is older than the next in the list i.e. InnerLoopIndex  + 1, then
                 UdtTempStudent = ArrayUdtStudent(InnerLoopIndex)                                            'Transfer current student data to be held temporarily by the temporary UDT UdtTempStudent
                 ArrayUdtStudent(InnerLoopIndex) = ArrayUdtStudent(InnerLoopIndex + 1)                       'Now move student InnerLoopIndex  + 1 data up the list into posistion InnerLoopIndex
                 ArrayUdtStudent(InnerLoopIndex + 1) = UdtTempStudent                                        'Then put values held by UdtTempStudent into position InnerLoopIndex  + 1
             End If
         Next InnerLoopIndex                                                                                 'Repeat nested to compare next pair of students
     Next OuterLoopIndex
     
     'Display students names and ages in ascending order
     strOutput = "The students in ascending age are:"
     For OuterLoopIndex = 1 To lngNUMBERSTUDENTS
         strOutput = strOutput & vbNewLine & ArrayUdtStudent(OuterLoopIndex).Name & " is: " & ArrayUdtStudent(OuterLoopIndex).Age
     Next OuterLoopIndex
     MsgBox strOutput
 ​
 End Sub

小代码

Sub 作业3_denglu_c()
     Dim name As String, key As String '定义用户名name为string型变量,密码key为string型变量
     Const tname As String = "小明", tkey As String = "888888"
     '此处声明常量方便用户名和密码改变后的代码修改，tname表示正确的用户名，tkey表示正确密码
      name = InputBox("请输入用户名") '提示输入用户名
      Select Case name '用select case 语句进行选择判断
      Case Is = tname '如果输入的用户名等于正确的用户名
         key = InputBox("请输入密码") '提示输入密码
             Select Case key
             Case Is = tkey '如果输入的密码等于正确的密码
                 MsgBox "登录成功" '输出语句“登录成功”
             Case Else '在用户名正确，密码错误的情况下
                 MsgBox "密码错误，登录失败" '输出语句"密码错误，登录失败"
             End Select
     Case Else '用户名不正确的情况下
         MsgBox "用户名不存在" '输出语句“用户名不存在”
     End Select
 End Sub
 ​
 ​
 Sub 排班表()
     Dim arr(), i As Long, j As Long, r As Long, k As Long, day As Long
     r = Range("a" & Rows.Count).End(xlUp).Row
     arr() = Range(Range("a1"), Range("ag" & r))
     j = 2
     k = 1
     For i = 2 To r
         Do Until j > 32
             If arr(i, j) <> "02" And arr(i, j) <> "*" And arr(i, j) <> "" Then
                 Do While arr(i, j + 1) <> "02" And arr(i, j + 1) <> "*" And arr(i, j + 1) <> ""
                     k = k + 1
                     j = j + 1
                 Loop
                 If k > day Then
                     day = k
                 End If
                 j = j + 1
                 k = 1
             Else
                 j = j + 1
             End If
         Loop
         If day > 7 Then
             Range("ag" & i) = day
         End If
         j = 2
         day = 0
     Next
 End Sub
 ​
 ​
 Sub InsertMerge()
   Dim sht As Worksheet, rows As Integer, i As Integer, n As Integer, m As Integer
   n = Worksheets.Count - 1
   For Each sht In Worksheets
     If sht.Index > 1 Then
       sht.Select
       ActiveSheet.UsedRange.Select
       Selection.Cut Range("B1")
       Range("A1").Value = "账号"
       rows = Selection.rows.Count
       For i = 2 To rows
         m = ((i - 2) Mod n) + 2
         Range("A" & i).Value = Worksheets.Item(m).Name
       Next
       'MsgBox Selection.Address
       If sht.Index = 2 Then
         sht.UsedRange.Copy Worksheets.Item(1).Range("A65536").End(xlUp)
       Else
          sht.UsedRange.Offset(1, 0).Copy Worksheets.Item(1).Range("A65536").End(xlUp).Offset(1, 0)
       End If
     
 ​
     End If
 ​
   Next
 End Sub