VBA示例：查找并分别列出找到的所有值

fanjy

发布于 2024-06-04 11:38:06

48200

代码可运行

文章被收录于专栏：完美Excel完美Excel

运行总次数：0

代码可运行

标签：VBA

如下图1所示，有一系列数据，其中Yl代表“Yellow”,Re代表“Red”，Bl代表“Blue”，Gr代表“Green”。

图1

现在，要查找各颜色对应的数值，并将找到的值列出来，如下图2所示。

图2

可以使用下面的过程：

Sub SeperateVars()
 Dim var As Variant, x As Long
 Dim yl As Long, re As Long, bl As Long, gr As Long
 
 With Application
   ReDim yVar(.CountIf(Range("B:B"), "yl") - 1, 1 To 1)
   ReDim rVar(.CountIf(Range("B:B"), "re") - 1, 1 To 1)
   ReDim bVar(.CountIf(Range("B:B"), "bl") - 1, 1 To 1)
   ReDim gVar(.CountIf(Range("B:B"), "gr") - 1, 1 To 1)
 End With
 var = Range("A2:B" & Range("A" & Rows.Count).End(xlUp).Row).Value
 
 For x = 1 To UBound(var)
   Select Case UCase(var(x, 2))
   Case "YL"
     yVar(yl, 1) = var(x, 1): yl = yl + 1
   Case "RE"
     rVar(re, 1) = var(x, 1): re = re + 1
   Case "BL"
     bVar(bl, 1) = var(x, 1): bl = bl + 1
   Case "GR"
     gVar(gr, 1) = var(x, 1): gr = gr + 1
   End Select
 Next x
 
 Range("G1") = "Yellow": Range("G2").Resize(UBound(yVar) + 1) = yVar
 Range("H1") = "Red": Range("H2").Resize(UBound(rVar) + 1) = rVar
 Range("I1") = "Blue": Range("I2").Resize(UBound(bVar) + 1) = bVar
 Range("J1") = "Green": Range("J2").Resize(UBound(gVar) + 1) = gVar
End Sub

也可以使用下面的过程：

Sub OneVar()
 Dim var As Variant, x As Long
 Dim y As Long, r As Long, b As Long, g As Long
 var = Range("A2:B" & Range("A" & Rows.Count).End(xlUp).Row).Value
 
 With Application
   ReDim oVar(.Max(.CountIf(Range("B:B"), "yl"), _
     .CountIf(Range("B:B"), "re"), _
     .CountIf(Range("B:B"), "bl"), _
     .CountIf(Range("B:B"), "gr")), 1 To 4)
 End With
 
 For x = 0 To 3
   oVar(0, x + 1) = Split("Yellow,Red,Blue,Green", ",")(x)
 Next x
 For x = 1 To UBound(var)
   Select Case UCase(var(x, 2))
   Case "YL"
     y = y + 1: oVar(y, 1) = var(x, 1)
   Case "RE"
     r = r + 1: oVar(r, 2) = var(x, 1)
   Case "BL"
     b = b + 1: oVar(b, 3) = var(x, 1)
   Case "GR"
     g = g + 1: oVar(g, 4) = var(x, 1)
   End Select
 Next x
 
 Range("G1").Resize(UBound(oVar) + 1, UBound(oVar, 2)) = oVar
End Sub

还可以借助于辅助工作表，如下图3所示。

图3

VBA过程如下：

Sub test()
 Dim rng As Range
 Dim CritVar As Variant
 Dim x As Long
 Dim aRng As Range
 
 CritVar = Sheet2.Range("A2:B" & Sheet2.Range("A" & Rows.Count).End(xlUp).Row).Value
 Set rng = Sheet1.Range("A1").CurrentRegion
 If Not Sheet1.AutoFilterMode Then
   rng.AutoFilter
 
   For x = 1 To UBound(CritVar)
     If Application.CountIf(Sheet1.Range("B:B"), CritVar(x, 1)) > 0 Then
     With rng
       .AutoFilter 2, CritVar(x, 1)
       .Offset(1).Resize(.Rows.Count - 1, 1).SpecialCells(xlCellTypeVisible).Copy
     End With
     With Sheet3
       Set aRng = .Cells(2, .Cells(1, Columns.Count).End(xlToLeft).Column + 1)
     End With
     With aRng
       .PasteSpecial xlValues
       .Offset(-1).Value = CritVar(x, 2)
     End With
     Application.CutCopyMode = False
   End If
 Next x
 rng.AutoFilter
 Sheet3.Select
End Sub