常用代码归集

jsgj2023

Sub 对数组的元素值进行排序()
Dim ws1  As Worksheet
Dim ws2 As Worksheet
Dim myarray As Variant
Set ws1 = Sheets(1)
Set ws2 = Sheets(2)
For i = 1 To 20
    For j = 1 To 2
        ws2.Cells(i, j) = Rnd
    Next j
Next i
myarray = ws2.Range("a1:e20").Value
With ws1
    .Range("a1").Resize(20, 2) = myarray
    .Range("a1:b20").Sort key1:=.Range("a1")
    myarray = .Range("a1:e20").Value
End With
End Sub

jsgj2023

Sub 双条件筛选()
Dim myrange As Range
Set myrange = Range("a1").CurrentRegion
With myrange
    .AutoFilter field:=2, Criteria1:="=李*"
    .AutoFilter field:=3, Criteria1:=">=90"
End With
End Sub

jsgj2023

Sub 判断表格是否有自动筛选()
Dim ws As Worksheet
Dim myautofilter As AutoFilter
Dim myrange As Range
Set ws = ActiveSheet
Set myautofilter = ws.AutoFilter
If Not myautofilter Is Nothing Then
    myautofilter.Range.AutoFilter
Else
    MsgBox "没有自动筛选"
End If
End Sub

jsgj2023

Sub 在条件区域内设置筛选条件()
Dim myrange1 As Range
Dim myrange2 As Range
Dim mycell As Range
Set myrange1 = Range("a1").CurrentRegion
Set myrange2 = Range("l1:m2")
myrange2.Cells(1, 1) = "总分"
myrange2.Cells(1, 2) = "数学"
myrange2.Cells(2, 1) = ">=360"
myrange2.Cells(2, 2) = ">=90"
MsgBox "条件设置完毕.请仔细察看条件区域."
myrange1.AdvancedFilter Action:=xlFilterInPlace, criteriarange:=myrange2
For Each mycell In myrange2.Cells
    mycell.Clear
Next
End Sub

jsgj2023

Sub 在条件区域呢设置多个筛选条件()
    Dim myRange1 As Range
    Dim myRange2 As Range
    Dim myCell As Range
    Set myRange1 = Range("A1").CurrentRegion
    Set myRange2 = Range("k1:M3")
    myRange2.Cells(1, 1) = "总分"
    myRange2.Cells(1, 2) = "班级"
    myRange2.Cells(1, 3) = "数学"
    myRange2.Cells(2, 1) = ">=360"
    myRange2.Cells(2, 2) = "初一2班"
    myRange2.Cells(3, 2) = "初一2班"
    myRange2.Cells(3, 3) = ">=90"
    MsgBox "条件设置完毕。请仔细察看条件区域。"
    myRange1.AdvancedFilter Action:=xlFilterInPlace, CriteriaRange:=myRange2
    For Each myCell In myRange2.Cells
        myCell.Clear
    Next
End Sub

jsgj2023

Sub 自动更改指定文字颜色及字体()
     Dim arr, brr, x&, y&, z&, d As Object
     Application.ScreenUpdating = False
     Set d = CreateObject("Scripting.Dictionary")
     With Sheets("Sheet1")
     arr = .Range("b18").CurrentRegion
     brr = .Range("c14").CurrentRegion
     For z = 1 To UBound(brr)
         s1 = brr(z, 1): a = Len(s1)
         For x = 1 To UBound(arr)
           s = arr(x, 2)
            For y = 1 To Len(s)
                 ss = Mid(s, y, a)
                 If ss = s1 Then
                     If Not d.exists(y) Then
                         d(y) = a
                     End If
                 End If
            Next y
            wz = d.keys: cd = d.items
             For i = 0 To UBound(wz)
                 With .Cells(17 + x, 2).Characters(Start:=wz(i), Length:=cd(i)).Font
                     If z = 1 Then
                         .ColorIndex = 5
                     ElseIf z = 2 Then
                         .ColorIndex = 4
                     Else
                         .ColorIndex = 3
                     End If
                         .Bold = True
                 End With
             Next i
         d.RemoveAll
         Next x
     Next z
     End With
End Sub

jsgj2023

自动实现统计三列数据中同一行三个词相同的次数  by liulang0808
Sub 按钮1_Click()   
     Dim brr()
     Application.ScreenUpdating = False
     arr = [b1].CurrentRegion
     Set d1 = CreateObject("scripting.dictionary")
     Set d2 = CreateObject("scripting.dictionary")
     a = 1
     For j = 2 To UBound(arr)
         For i = 1 To 3
             If Not d1.exists(arr(j, i)) Then
                 d1(arr(j, i)) = a
                 a = a + 1
             End If
         Next i
     Next j
     For j = 2 To UBound(arr)
         ReDim brr(1 To d1.Count)
         For i = 1 To 3
             brr(d1(arr(j, i))) = arr(j, i)
         Next i
         d2(Join(brr)) = 1 + d2(Join(brr))
     Next j
     [i2].Resize(d2.Count) = WorksheetFunction.Transpose(d2.keys)
     [j2].Resize(d2.Count) = WorksheetFunction.Transpose(d2.items)
     Application.ScreenUpdating = True
End Sub

jsgj2023

Sub 取消筛选模式显示全部数据()
    Dim ws As Worksheet
    Set ws = ThisWorkbook.ActiveSheet
    With ws
        If .FilterMode Then
            .ShowAllData
        End If
    End With
End Sub

jsgj2023

Sub 将按条件筛选出的数据复制到新建的表格中()
    Dim myRange As Range
    Dim myRangeD As Range
    Dim myRange1 As Range
    Dim myRange2 As Range
    Dim ws As Worksheet
    Set myRange1 = Range("A1").CurrentRegion
    Set myRange2 = Range("k1:M3")
    Set myRange = Worksheets(1).Range("A1").CurrentRegion
    With Worksheets
        Set ws = .Add(After:=.Item(.Count))
        Set myRangeD = ws.Range("A1")
    End With
    With myRange2
        .Cells(1, 1) = "总分"
        .Cells(1, 2) = "班级"
        .Cells(1, 3) = "数学"
        .Cells(2, 1) = ">=360"
        .Cells(2, 2) = "初一2班"
        .Cells(3, 2) = "初一2班"
        .Cells(3, 3) = ">=90"
    End With
    myRange1.AdvancedFilter Action:=xlFilterCopy, _
        CriteriaRange:=myRange2, CopyToRange:=myRangeD
    myRange2.Clear
End Sub

jsgj2023

Sub RemoveDuplicates法去重复值()
    Dim myRange As Range
    Set myRange = Range("A1:C11")
    myRange.RemoveDuplicates Columns:=Array(1, 2, 3), Header:=xlYes
End Sub