常用代码归集

jsgj2023

Sub find方法指定范围和条件查询()
Dim myrange1 As Range
Dim myrange2 As Range
Dim myscore As Long
Dim mykey As String
Set myrange1 = Columns("B")
mykey = "刘方园"
Set myrange2 = myrange1.Find(what:=mykey)
If Not myrange2 Is Nothing Then
    myscore = myrange2.Offset(, 5).Value
    MsgBox mykey & "的总成绩为:" & myscore
Else
    MsgBox "没有找到符合条件的单元格!"
End If
Set myrange1 = Nothing
Set myrange2 = Nothing
End Sub

jsgj2023

Sub collection集合方法指定范围和条件查询()
Dim myarray As Variant
Dim myscore As Single
Dim mycollection As New Collection
Dim mykey As String
Dim myerrnum As Long
Dim i As Long
myarray = Range("a1").CurrentRegion.Value
For i = 1 To UBound(myarray)
    mycollection.Add Item:=myarray(i, 5), key:=CStr(myarray(i, 2))
Next i
mykey = "刘方圆"
On Error Resume Next
myscore = mycollection(mykey)
myerrnum = Err.Number
On Error GoTo 0
If myerrnum = 0 Then
    MsgBox mykey & "的化学成绩为:" & myscore
Else
    MsgBox "没有找到符合条件的单元格!"
End If
    Set mycollection = Nothing
End Sub

jsgj2023

Sub dcounta和dget法指定范围和条件查询()
Dim myrange1 As Range
Dim myrange2 As Range
Dim myscore As Long
Dim mykey As String
Set myrange1 = Columns("A:H")
Set myrange2 = Range("j1:j2")
mykey = "刘方园"
myrange2.Cells(1, 1) = myrange1.Range("b1")
myrange2.Cells(2, 1) = mykey
myscore = WorksheetFunction.DCountA(myrange1, 1, myrange2)
If myscore = 1 Then
    myscore = WorksheetFunction.DGet(myrange1, 7, myrange2)
    MsgBox mykey & "的总成绩为:" & myscore
Else
    MsgBox "没有找到符合条件的单元格!"
End If
myrange2.Clear
Set myrange1 = Nothing
Set myrang2 = Nothing
End Sub

jsgj2023

Sub like法指定范围和条件统计()
Dim myrange1 As Range
Dim myrange2 As Range
Dim mynum As Single
Set myrange1 = Columns("B")
For Each myrange2 In myrange1.Cells
    If myrange2.Value Like "*李*" Then
        myrange2.EntireRow.Select
        MsgBox "查找下一个", vbInformation
        mynum = mynum + 1
    End If
Next
MsgBox "姓名中包含有[李]的记录共有 " & mynum & "条"
Set myrange1 = Nothing
Set myrange2 = Nothing
End Sub

jsgj2023

Sub countif法指定范围和条件统计()
Dim myrange  As Range
Dim mynum  As Long
Set myrange = Columns("B")
mynum = WorksheetFunction.CountIf(myrange, "=*李*")
MsgBox "姓名中包含有[李]的记录共有" & mynum & "条"
Set myrange = Nothing
End Sub

jsgj2023

Sub 多条件dcounta法指定范围查询()
Dim myrange1 As Range
Dim myrange2 As Range
Dim mynum As Long
Dim mystr As String
Set myrange1 = Columns("A:G")
Set myrange2 = Range("K1:M2")
myrange2.Cells(1, 1) = myrange1.Range("B1")
myrange2.Cells(1, 2) = myrange1.Range("C1")
myrange2.Cells(1, 3) = myrange1.Range("D1")
myrange2.Cells(2, 1) = "*王*"
myrange2.Cells(2, 2) = ">=90"
myrange2.Cells(2, 3) = ">=90"
mynum = WorksheetFunction.DCountA(myrange1, 1, myrange2)
MsgBox "姓名中包含有[李]且数学和语文都在90分以上的学生共有" & mynum & "名"
myrange2.Clear
Set myrange1 = Nothing
Set myrange2 = Nothing
End Sub

jsgj2023

Sub find法查询指定条件字段的单元格地址()
    Dim wb As Workbook
    Dim ws As Worksheet
    Dim myrange As Range
    Dim myfind As Boolean
    myfind = False
    For Each wb In Workbooks
        For Each ws In wb.Worksheets
            Set myrange = ws.Cells.Find(what:="王无忌")
            If Not myrange Is Nothing Then
                myfind = True
                MsgBox "在工作簿" & wb.Name & "的工作表" & ws.Name & "中" & myrange.Address
            End If
        Next
    Next
    If myfind = False Then
        MsgBox "没有找到符合条件的单元格"
    End If
    Set wb = Nothing
    Set ws = Nothing
    Set myrange = Nothing
End Sub

jsgj2023

Sub 指定工作表和数据区域降序及升序排序()
Dim ws  As Worksheet
Dim myrange As Range
Set ws = Worksheets(1)
Set myrange = ws.UsedRange
myrange.Sort key1:="姓名", order1:=xlDescending, Header:=xlYes, SortMethod:=xlPinYin
myrange.Sort key1:="姓名", order1:=xlAscending, Header:=xlYes, SortMethod:=xlPinYin
Set myrange = Nothing
End Sub

jsgj2023

Sub 按自定义序列排序()
    Dim ws1 As Worksheet
    Dim ws2 As Worksheet
    Dim myrange1 As Range
    Dim myrange2 As Range
    Set ws1 = Worksheets(1)
    Set ws2 = Worksheets(2)
    ws2.Cells.Delete shift:=xlUp
    Set myrange1 = ws1.UsedRange
    Set myrange2 = ws2.Range("a1")
    myrange1.Copy
    myrange2.PasteSpecial Paste:=xlPasteValues
    Application.CutCopyMode = False
    Set myrange2 = ws2.UsedRange
    myrange2.Sort key1:=ws2.Range("b1"), order1:=xlAscending, Header:=xlYes, ordercustom:=8
    Set myrange1 = Nothing
    Set myrange2 = Nothing
    Set ws1 = Nothing
    Set ws2 = Nothing
End Sub

jsgj2023

Sub 按多关键字数组排序()
Dim ws As Worksheet
Dim myrange As Range
Dim myarray As Variant
Dim i As Integer
Set ws = Worksheets(1)
Set myrange = ws.Range("a1").CurrentRegion
myarray = Array("物理", "化学", "语文", "数学", "总分")
With myrange
    For i = 0 To UBound(myarray)
        .Sort key1:=myarray(i), order1:=xlDescending, Header:=xlYes
    Next i
End With
Set myrange = Nothing
Set ws = Nothing
End Sub