常用代码归集

jsgj2023

Sub 自动查询_条目数组用法()
Dim d  As Object
Dim arr As Variant
Dim i As Integer
Dim j  As Integer
Dim rng As Range
Set d = CreateObject("scripting.dictionary")
With Sheets("data")
    arr = .Range("a2:e" & .Cells(Rows.Count, 1).End(xlUp).Row)
End With
For i = 1 To UBound(arr)
    d(arr(i, 1)) = Array(arr(i, 2), arr(i, 3), arr(i, 4), arr(i, 5))
    j = d(arr(i, 1))
Next
For Each rng In Range("a3:a" & Cells(Rows.Count, 1).End(xlUp).Row)
    rng.Offset(0, 1).Resize(1, 4) = d(rng.Value)
Next
End Sub

jsgj2023

Sub 分类计数_()
Dim arr1 As Variant
Dim d As Object
Dim arr As Variant
Dim i As Integer
Dim rng As Variant
Set d = CreateObject("scripting.dictionary")
arr = Range("b2:b" & Cells(Rows.Count, 2).End(xlUp).Row)
For Each rng In arr
    i = d(rng)
    d(rng) = d(rng) + 1
    i = d(rng)
Next
[e1].Resize(d.Count) = Application.Transpose(d.keys)
[f1].Resize(d.Count) = Application.Transpose(d.items)
End Sub

jsgj2023

Sub 分类求和_()
Dim arr1  As Variant
Dim d As Object
Dim arr As Variant
Dim i As Integer
Set d = CreateObject("scripting.dictionary")
arr = Range("b2:c" & Cells(Rows.Count, 2).End(xlUp).Row)
For i = 1 To UBound(arr)
    d(arr(i, 1)) = d(arr(i, 1)) + arr(i, 2)
Next
[e8].Resize(d.Count) = Application.Transpose(d.keys)
[f8].Resize(d.Count) = Application.Transpose(d.items)
End Sub

jsgj2023

Sub 字典与数组结合去重()
Dim d  As Object
Dim arr As Variant
Dim rng  As Variant
Dim rngs  As Variant
Dim arr1 As Variant
Dim i  As Variant
Dim n  As Integer
Set d = CreateObject("scripting.dictionary")
arr = Sheet1.Range("a1:b" & Sheet1.Cells(Rows.Count, "a").End(3).Row)
For Each rng In arr
    arr1 = VBA.Split(rng, "|")
    For Each rngs In arr1
        d(rngs) = ""
    Next
    i = VBA.Join(d.keys, "|")
    n = n + 1
    Sheet2.Cells(n, "a") = i
    d.RemoveAll
Next
End Sub

jsgj2023

Sub 多表求不重复值()
Dim d As Object
Dim sh  As Variant
Dim c As Variant
Dim arr As Variant
Set d = CreateObject("scripting.dictionary")
For Each sh In Sheets
    With sh
        If .Name <> "品名" Then
            arr = .Range("a1:a" & .Cells(Rows.Count, 1).End(3).Row)
            For Each Rng In arr
                d(Rng) = ""
            Next
        End If
    End With
Next sh
[a1].Resize(d.Count) = Application.Transpose(d.keys)
End Sub

jsgj2023

Sub 数组法分类汇总()
Dim arr1() As Variant
Dim arr As Variant
Dim i  As Integer
Dim j  As Integer
Dim n As Integer
arr = Range("a2:c13")
For i = 1 To UBound(arr)
    ReDim Preserve arr1(1 To 2, 1 To n + 1)
    For j = 1 To UBound(arr1, 2)
        If arr1(1, j) = arr(i, 1) Then
            arr1(2, j) = arr1(2, j) + arr(i, 3)
            GoTo 100
        End If
    Next
    n = n + 1
    arr1(1, n) = arr(i, 1)
    arr1(2, n) = arr(i, 3)
100:
Next i
[e2].Resize(n, 2) = Application.Transpose(arr1)
End Sub

aman1516

马克收藏，谢谢分享

jsgj2023

Sub 数组冒泡排序()
Dim arr As Variant
Dim i  As Integer
Dim j  As Integer
Dim k As Integer
arr = Range("a1").CurrentRegion
For i = 1 To UBound(arr)
    For j = i + 1 To UBound(arr)
        If arr(i, 1) > arr(j, 1) Then
            k = arr(i, 1)
            arr(i, 1) = arr(j, 1)
            arr(j, 1) = k
        End If
    Next
Next i
[b1].Resize(UBound(arr)) = arr
End Sub

jsgj2023

Sub 数组法格式化单元格()
Dim arr As Variant
Dim i As Integer
Dim n As Integer
Dim k As Variant
Dim rng As Range
Cells.ClearFormats
arr = Range("g2:g" & Cells(Rows.Count, "g").End(3).Row)
For i = 1 To UBound(arr)
    If arr(i, 1) >= 330 Then
        Set rng = Cells(i + 1, "g").EntireRow.Range("a1:g1")
        n = n + 1
        If n = 1 Then Set rngs = rng Else Set rngs = Union(rngs, rng)
        k = rngs.Address
    End If
Next
rngs.Interior.ColorIndex = 3
End Sub

jsgj2023

Sub filter法筛选()
Dim i As Integer
Dim arr As Variant
Dim a As Variant
Dim n As Integer
Dim c As Variant
Range("d2:f1000").Clear
i = Cells(Rows.Count, 1).End(3).Row
Range("c2:c" & i).FormulaArray = "=a2:a" & i & " & ""-"" & b2:b" & i
arr = Range("c2:c1" & i)
Range("c2:c1" & i).Clear
a = Filter(Application.Transpose(arr), [g1], True)
For Each b In a
    n = n + 1
    c = Split(b, "-")
    Cells(n + 1, "d") = c(0)
    Cells(n + 1, "e") = c(1)
Next
End Sub