Question

我试图根据它的第4列值突出显示某些单元格。

基本上，如果第4列值为负，那么我们从头开始搜索第4列，如果存在正匹配（即第4列值为正，然后匹配相应的第3列和第6列值），则突出显示所有这些在一起。

此外，一旦配对并突出显示，就不应该在中间循环中再次拾取它，因此在那里添加了另一个条件。

这段代码在某种程度上正在完成我的工作。但在它之间它错过了一些可以与积极因素相匹配的负面价值观。任何帮助将不胜感激

Sub Button1_Click()
Dim rownumber As Integer
Dim ColumnC, ColumnF, ColumnC1, ColumnF1 As String
Dim ColumnD, ColumnD1 As Integer
Dim subrownumber As Integer
Dim Condition As Boolean

rownumber = 1

Do
ColumnD = Cells(rownumber, 4).Value
ColumnC = Cells(rownumber, 3).Value
ColumnF = Cells(rownumber, 6).Value
Condition = False

If (ColumnD < 0) Then
    subrownumber = 1
    Do
    ColumnD1 = Cells(subrownumber, 4).Value
    ColumnC1 = Cells(subrownumber, 3).Value
    ColumnF1 = Cells(subrownumber, 6).Value
            If (ColumnD1 = ColumnD * -1 And ColumnF1 = ColumnF And ColumnC1 = ColumnC) And _
              Cells(subrownumber, 4).Interior.ColorIndex <> 37 Then

                Cells(subrownumber, 4).Interior.ColorIndex = 37
                Cells(subrownumber, 3).Interior.ColorIndex = 37
                Cells(subrownumber, 6).Interior.ColorIndex = 37
                Cells(rownumber, 4).Interior.ColorIndex = 37
                Cells(rownumber, 3).Interior.ColorIndex = 37
                Cells(rownumber, 6).Interior.ColorIndex = 37
                Condition = True
            End If
    subrownumber = subrownumber + 1
    Loop Until IsEmpty(Cells(subrownumber, 4)) Or Condition = True
End If
rownumber = rownumber + 1
Loop Until IsEmpty(Cells(rownumber, 4))
End Sub

Answer 1

特别是在没有样本数据的情况下，遵循相当棘手的代码，但我认为你应该按照自己的意愿去做。您几乎不得不手动查看符合您预期的内容以及按照什么顺序排列，然后逐步完成您的例程，看看它是否符合您的预期。

我无法帮助您认为最好创建两个列表：一个带有负数，另一个带有正数，然后只匹配一个与另一个匹配。下面的代码就是这样。当我第一次写它时，我以为你在帖子中说你想忽略重复，所以这段代码就是这样。如果那不是您想要做的，那么将需要进行一些调整。

你可以使用任何列表或数组，但我已经去了一个集合，因为密钥可以是你的三个单元格值的连续，因此可以快速查找。

Dim ws As Worksheet
Dim rng As Range
Dim posData As New Collection
Dim negData As New Collection
Dim key As String
Dim r As Long
Dim v As Variant

Set ws = ThisWorkbook.Worksheets("Sheet1")

On Error Resume Next
For r = 1 To ws.UsedRange.Rows.Count
    key = ws.Cells(r, 3).Text & " " & _
          CStr(Abs(ws.Cells(r, 4).Value2)) & " " & _
          ws.Cells(r, 6).Text
    If ws.Cells(r, 4).Value2 < 0 Then
        negData.Add r, key
    Else
        posData.Add r, key
    End If
Next

For Each v In negData
    key = ws.Cells(v, 3).Text & " " & _
          CStr(Abs(ws.Cells(v, 4).Value2)) & " " & _
          ws.Cells(v, 6).Text
    Err.Clear
    r = posData(key)
    If Err = 0 Then
        Set rng = Union(ws.Cells(v, 3), ws.Cells(v, 4), ws.Cells(v, 6), _
                        ws.Cells(r, 3), ws.Cells(r, 4), ws.Cells(r, 6))
        rng.Interior.ColorIndex = 37
    End If
Next

更新：包含重复项的代码

以下是一些可以执行您所要求的代码。你提到你不熟悉列表和数组，所以我写了一个包含你可以学习的解决方案。

重要提示：我使用了Dictionary类，这对于存储数据列表非常有用。在Visual Basic编辑器中，您需要转到工具 - ＆gt;引用并选择Microsoft Scripting Runtime以访问此类。

我攻击这种方式的方法是拥有Dictionary个唯一值（Dcol，Ccol和Fcol），并在每个Item另一个Dictionary内包含所有重复值。对于每个新行，代码会检查Dictionary中是否存在未配对的倒数值。如果有，那么它将两者配对并绘制细胞;如果没有，它会将值添加到字典中并继续前进。

这可能更适合您的需求，它只会循环通过工作表一次，而您的每一行检查整个工作表... 10 x 10很好，但10,000 x 10,000会有一个时间问题的用户

享受！

Public Sub MatchMaker()

    Const SEP As String = "|"

    Dim singlesClub As Dictionary
    Dim duplicateSinglies As Dictionary
    Dim aMatchForMe(1) As String

    Dim ws As Worksheet
    Dim rng As Range
    Dim rowNum As Long
    Dim startRow As Long
    Dim endRow As Long
    Dim cText As String
    Dim dVal As Integer
    Dim fText As String

    ' Initialise the objects.
    Set ws = ThisWorkbook.Worksheets("Sheet1")
    Set singlesClub = New Dictionary
    Set duplicateSinglies = New Dictionary

    ' Define the loop parameters.
    startRow = IIf(Len(ws.Cells(1, "D").Text) > 0, 1, ws.Cells(1, "D").End(xlDown).Row)
    endRow = ws.Cells(ws.Rows.Count, "D").End(xlUp).Row

    ' Loop through the worksheet.
    For rowNum = startRow To endRow

        ' Check the row is valid.
        If Len(ws.Cells(rowNum, "C").Text) > 0 And _
           Len(ws.Cells(rowNum, "D").Text) > 0 And _
           Len(ws.Cells(rowNum, "F").Text) > 0 And _
           IsNumeric(ws.Cells(rowNum, "D")) Then

            ' Create the key name - used to identify our dictionary items,
            ' and assign to the key array.
            cText = ws.Cells(rowNum, "C").Text
            dVal = ws.Cells(rowNum, "D").Value2
            fText = ws.Cells(rowNum, "F").Text

            ' Array index: 0=this key, 1=reciprocal "D" value key.
            aMatchForMe(0) = CStr(dVal) & SEP & cText & SEP & fText
            aMatchForMe(1) = CStr(dVal * -1) & SEP & cText & SEP & fText

            ' Define the range of this row
            Set rng = Union(ws.Cells(rowNum, "C"), _
                               ws.Cells(rowNum, "D"), _
                               ws.Cells(rowNum, "F"))


            ' Check to see if the reciprocal key exists in the unpaired dictionary.
            ' If it does, then we have at least one match.
            ' If it doesn't then we must add this key to the unpaired dictionary.

            If singlesClub.Exists(aMatchForMe(1)) Then

                ' Take the first of the duplicate values and acquire its range
                Set duplicateSinglies = singlesClub(aMatchForMe(1))

                ' Fill the cells of both pairs.
                Set rng = Union(duplicateSinglies.Items(0), rng)
                rng.Interior.ColorIndex = (rowNum Mod 17) + 2

                ' Remove the value from the unpaired dictionary.
                duplicateSinglies.Remove (duplicateSinglies.Keys(0))
                If duplicateSinglies.Count = 0 Then singlesClub.Remove (aMatchForMe(1))

            Else

                ' Add this value to the unpaired list.
                If singlesClub.Exists(aMatchForMe(0)) Then
                    Set duplicateSinglies = singlesClub(aMatchForMe(0))
                    duplicateSinglies.Add rowNum, rng
                Else
                    Set duplicateSinglies = New Dictionary
                    duplicateSinglies.Add rowNum, rng
                    singlesClub.Add aMatchForMe(0), duplicateSinglies
                End If

            End If

        End If

    Next


End Sub

Answer 2

终于到了那里。

Sub Button1_Click()
Dim rownumber As Integer
Dim ColumnC, ColumnF, ColumnC1, ColumnF1 As String
Dim ColumnD, ColumnD1 As Single
Dim subrownumber As Integer
Dim Condition As Boolean
rownumber = 1
Do
    ColumnD = Cells(rownumber, 4).Value
    ColumnC = Cells(rownumber, 3).Value
    ColumnF = Cells(rownumber, 6).Value
    Condition = False

If (ColumnD < 0) Then
    subrownumber = 1
    Do
        ColumnD1 = Cells(subrownumber, 4).Value
        ColumnC1 = Cells(subrownumber, 3).Value
        ColumnF1 = Cells(subrownumber, 6).Value
            If (ColumnD1 = ColumnD * -1 And ColumnF1 = ColumnF And ColumnC1 = ColumnC) And _
             Cells(subrownumber, 4).Interior.ColorIndex <> 37 And _
             Cells(rownumber, 4).Interior.ColorIndex <> 37 Then
                Cells(subrownumber, 4).Interior.ColorIndex = 37
                Cells(subrownumber, 3).Interior.ColorIndex = 37
                Cells(subrownumber, 6).Interior.ColorIndex = 37
                Cells(rownumber, 4).Interior.ColorIndex = 37
                Cells(rownumber, 3).Interior.ColorIndex = 37
                Cells(rownumber, 6).Interior.ColorIndex = 37
                Condition = True
            End If
    subrownumber = subrownumber + 1
    Loop Until IsEmpty(Cells(subrownumber, 4)) Or Condition = True
End If
rownumber = rownumber + 1
Loop Until IsEmpty(Cells(rownumber, 4))
End Sub

Excel VBA - 为某些人做循环工作但不是为所有人做

2 个答案: