常用代码归集

jsgj2023

Function 个人所得税(curP As Currency)
    Dim curT As Currency
    curP = curP - 1600 '1600为扣除数
    If curP > 0 Then
        Select Case curP
            Case Is <= 500
                curT = curP * 0.05
            Case Is <= 2000
                curT = (curP - 500) * 0.1 + 25
            Case Is <= 5000
                curT = (curP - 2000) * 0.15 + 125
            Case Is <= 20000
                curT = (curP - 5000) * 0.2 + 375
            Case Is <= 40000
                curT = (curP - 20000) * 0.25 + 1375
            Case Is < 60000
                curT = (curP - 40000) * 0.3 + 3375
            Case Is < 80000
                curT = (curP - 60000) * 0.35 + 6375
            Case Is < 100000
                curT = (curP - 80000) * 0.4 + 10375
            Case Else
                curT = (curP - 100000) * 0.45 + 15375
        End Select
        个人所得税 = curT
    Else
        个人所得税 = 0
    End If
End Function

Sub 计算()
    For i = 4 To 9
        Sheets(1).Cells(i, 8).Value = 个人所得税(Sheets(1).Cells(i, 6).Value)
    Next
End Sub

jsgj2023

Sub 输出ascii码表()
    Dim a As Integer, i As Integer
    i = 3
    For a = 32 To 126
        Sheets(1).Cells(i, 1) = a
        Sheets(1).Cells(i, 2) = Chr(a)
        i = i + 1
    Next
End Sub

jsgj2023

Sub 统计10元钱换为零钱的方法()
    Dim t As Integer
    Dim i As Integer
    Dim j As Integer
    Dim k As Integer
    Dim l As Integer
    Dim m As Integer
    Dim n As Integer
    For i = 0 To 100    '1角
        For j = 0 To 50 '2角
            For k = 0 To 20 '5角
                For l = 0 To 10 '1元
                    For m = 0 To 5  '2元
                        For n = 0 To 2  '5元
                            If i + 2 * j + 5 * k + 10 * l + 20 * m + 50 * n = 100 Then
                                t = t + 1
                                Sheets(1).Cells(t + 1, 1) = i
                                Sheets(1).Cells(t + 1, 2) = j
                                Sheets(1).Cells(t + 1, 3) = k
                                Sheets(1).Cells(t + 1, 4) = l
                                Sheets(1).Cells(t + 1, 5) = m
                                Sheets(1).Cells(t + 1, 6) = n
                            End If
                        Next
                    Next
                Next
            Next
        Next
    Next
    MsgBox "10元换为零钱共有" & t & "种方法！"
End Sub

jsgj2023

Option Base 1
Sub 用数组填充单元格区域()
Dim i As Long
Dim j As Long
Dim col As Long
Dim row As Long
Dim arr() As Long
row = Application.InputBox(prompt:="输入行数:", Type:=2)
col = Application.InputBox(prompt:="输入列数:", Type:=2)
ReDim arr(row, col)
For i = 1 To row
    For j = 1 To col
        arr(i, j) = (i - 1) * col + j
    Next j
Next i
Set Rng = Sheets(1).Range(Cells(1, 1), Cells(row, col))
Rng.Value = arr
End Sub

jsgj2023

Sub 计算选中区域数值的和()
    Dim r As Variant
    Dim t As Long
    For Each r In Selection
        If IsNumeric(r.Value) Then
            t = t + r.Value
        End If
    Next
    MsgBox "所选区域数值之和为：" & t
End Sub

jsgj2023

Sub 通过密码验证后进入系统()
    Dim strpassword As String
    Dim i As Integer
    Do
        strpassword = InputBox("请输入密码")
        If strpassword = "Adele" Then
            Exit Do
        Else
            MsgBox ("请输入正确的密码!")
        End If
        i = i + 1
    Loop While i < 3
    If i >= 3 Then
        MsgBox "非法用户,系统将退出!"
        Application.Quit
    Else
        MsgBox "欢迎使用本系统!"
    End If
End Sub

jsgj2023

Sub 指定查询条件查找()
    Dim myrange As Range
    Set myrange = Cells.Find(what:="刘方圆", after:=ActiveCell, LookIn:=xlValues, _
    lookat:=xlPart, searchorder:=xlByRows, searchdirection:=xlNext, MatchCase:=False)
    If myrange Is Nothing Then
        MsgBox "没有找到符合条件的单元格!"
    Else
        MsgBox "符合条件的单元格为:" & myrange.Address(False, False)
        myrange.Activate
    End If
    Set myrange = Nothing
End Sub

jsgj2023

Sub 指定查询范围和查询条件查找()
Dim myrange1 As Range
Dim myrange2 As Range
Dim myrow As Long
Set myrange1 = Columns("B")
On Error Resume Next
myrow = worksheetfuntion.Match("刘方圆", myrange1, 0)
On Error GoTo 0
If myrow = 0 Then
    MsgBox "没有找到符合条件的单元格!"
Else
    Set myrange2 = myrange1.Cells(myrow)
    MsgBox "符合条件的单元格为:" & myrange2.Address(False, False)
    myrange2.EntireRow.Select
End If
    Set myrange1 = Nothing
    Set myrange2 = Nothing
End Sub

1103049271

楼主可以放上事例文件吗？光看代码不好应用

jsgj2023

Sub vlookup指定范围和条件查询()
    Dim myrange As Range
    Dim myscore As Single
    Dim mykey As String
    Dim myerrnum As Long
    Set myrange = Columns("b:d")
    mykey = "刘方圆"
    On Error Resume Next
    myscore = WorksheetFunction.VLookup(mykey, myrange, 3, False)
    myerrnum = Err.Number
    On Error GoTo 0
    If myerrnum = 0 Then
        MsgBox mykey & "的语文成绩为:" & myscore
    Else
        MsgBox "没有找到符合条件的单元格!"
    End If
    Set myrange = Nothing
End Sub