VBA 按列查找小工具类似lookUp函数

ゝ一世哀愁。 2021-12-18 07:27 249阅读 0赞

![1519983-20190226082548692-1188920103.png][]

如上图，查找A列的数据在D,F列是否存在，如果存在背景色变绿，如果不存在则A列的背景色变红。

直接贴上代码：

![ContractedBlock.gif][] ![ExpandedBlockStart.gif][]

1 Private Sub CommandButton1_Click()
    2     Call lookUpAToDF
    3 End Sub

1 Public Sub lookUpAToDF()
     2    Dim a, d, f As Long
     3    'Count of non-empty data in colum A,D,F
     4    a = Application.WorksheetFunction.CountA(Range("A:A"))
     5    d = Application.WorksheetFunction.CountA(Range("D:D"))
     6    f = Application.WorksheetFunction.CountA(Range("F:F"))
     7    Dim ac, dc, fc As Integer
     8    'loop the A
     9    For ac = 1 To a Step 1
    10        Dim aTxt As String
    11        ' get column A value
    12        aTxt = TrimSpace(Cells(ac, 1).Text)
    13        If aTxt = "" Then
    14            Exit For
    15        End If
    16        ' add flg var for switch selected aTxt
    17        Dim flg As Boolean
    18        flg = True
    19        For dc = 1 To d Step 1
    20            Dim dTxt As String
    21            dTxt = TrimSpace(Cells(dc, 4).Text)
    22            If aTxt = dTxt Then
    23                flg = False
    24                Exit For
    25            End If
    26        Next dc
    27        'if column D selected result is empty then
    28        'loop the colum F
    29        If flg Then
    30            For fc = 1 To f Step 1
    31                Dim fTxt As String
    32                fTxt = TrimSpace(Cells(fc, 6).Text)
    33                If aTxt = fTxt Then
    34                    flg = False
    35                    Exit For
    36                End If
    37            Next fc
    38        End If
    39        If flg Then
    40            Cells(ac, 1).Interior.ColorIndex = 3 'red
    41        Else
    42            Cells(ac, 1).Interior.ColorIndex = 4 'green
    43        End If
    44    Next ac
    45    MsgBox "find completed!"
    46 End Sub
    47 Public Function TrimSpace(strItem As String) As String
    48    Dim resultStr As String
    49    resultStr = LTrim(strItem)
    50    resultStr = RTrim(resultStr)
    51    TrimSpace = resultStr
    52 End Function

代码还没有优化，行数达到10000+的时候会有卡顿。

转载于:https://www.cnblogs.com/forbetter223/p/10435153.html

[1519983-20190226082548692-1188920103.png]: /images/20211218/300910b62aec49cd9bfb1612e34130b4.png
[ContractedBlock.gif]: https://images.cnblogs.com/OutliningIndicators/ContractedBlock.gif
[ExpandedBlockStart.gif]: /images/20211218/a048b4fe0b744deabcd77cc3320a33bf.png