Excel VBA - 如果列中的值等于则合并单元格

Question

我正在试图弄清楚如何实现一个宏来获得如下结果：

我不知道该怎么做。这是我到目前为止所做的。

我想要额外的“Action”列，如果“State”列中的值例如 R1 为空或“no_fix”，则 QM（绿色）否则 QA（红色）。

我有大约 5000 行的数据

您好，谢谢它按我的预期工作。但是，在测试了我的数据后，我发现我需要检查其他条件。

1.另外对于 QM 和 QA： 如果 value = "ST"，请检查 G 列 如果 value = 0，则检查 H 列

2.质量检查

如果值 =“LM 没有 TC”，则检查 C 列，如果 value = "no state" 检查列 E if value = "No IPIS" if any of values = true 然后是 QA

    Sub MergeSameCell()
    'area
    Dim Rng As Range, xCell As Range, Test As Range
    Dim Rng1 As Range
    Dim xRows As Integer
    xTitleId = "Merge duplicated cells"
    Set WorkRng = Application.Selection
    Set WorkRng = Application.InputBox("Range", xTitleId, WorkRng.Address, 
    Type:=8)
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    xRows = WorkRng.Rows.Count
    For Each Rng In WorkRng.Columns
    For i = 1 To xRows - 1
        For j = i + 1 To xRows
            'If Rng.Cells(i, 1).Value > 0 And Rng.Cells(j, 1).Value > 0 Then
            If Rng.Cells(i, 1).Value <> Rng.Cells(j, 1).Value Then
                  Exit For
            End If
        Next
        'WorkRng.Parent.Range(Rng.Cells(i, 1), Rng.Cells(j - 1, 1)).Merge
        'Text = WorkRng.Parent.Range(Rng.Cells(i, 1), Rng.Cells(j - 1, 1))
        i = j - 1
        For Each Rng1 In Range(Rng.Cells(i, 1), Rng.Cells(j - 1, 1))
            For Z = 1 To 13
         'MsgBox i
        'MsgBox j
            If Rng1.Offset(Z, 1).Value = "no_to_fix" Or Rng1.Offset(Z, 
        1).Value 
       = "" Then

            'WorkRng.Parent.Range(Rng.Cells(i, 1), Rng.Cells(j - 1, 
         1)).Merge
            Rng1.Cells.Offset(Z, 1).Interior.ColorIndex = 37
            'MsgBox "supcio"
            End If
            Next
        Next
    Next
    Next
    WorkRng.VerticalAlignment = xlCenter
    Application.DisplayAlerts = True
    Application.ScreenUpdating = True
    End Sub

Answer 1

以下代码将执行您想要的合并，如果我理解问题的第二部分的意思，会将第一列设置为“QM”（如果第四列从不为空或“no_fix”）或“QA”。

代码假定您将使用InputBox 选择包含四列的范围，第一列是包含“QM”或“QA”的列，第二列是您的“Req”列，以及第四个是您的“状态”列。 （代码从不查看第三列中的内容。）

Sub MergeSameCell()
    Dim WorkRng As Range
    xTitleId = "Merge duplicated cells"
    Set WorkRng = Selection
    Set WorkRng = Application.InputBox("Range", xTitleId, WorkRng.Address, Type:=8)

    Application.ScreenUpdating = False
    Application.DisplayAlerts = False

    Dim startRow As Long
    Dim endRow As Long
    Dim r As Long
    Dim isQM As Boolean
    'Use "startRow" to keep track of the start of each block
    startRow = 1
    With WorkRng
        'Loop through each row in the selected range
        For endRow = 1 To .Rows.Count
            If .Cells(endRow + 1, 2).Value <> .Cells(startRow, 2).Value Then
                'Only do something if the next row has a different value in the second column

                'merge rows in the first and second columns
                .Worksheet.Range(.Cells(startRow, 1), .Cells(endRow, 1)).MergeCells = True
                .Worksheet.Range(.Cells(startRow, 2), .Cells(endRow, 2)).MergeCells = True

                'Check for "no_fix" or blank
                isQM = True  ' Assume it is a "QM" until we determine it isn't
                For r = startRow To endRow
                    If .Cells(r, 4).Value <> "" And .Cells(r, 4).Value <> "no_fix" Then
                        'If the 4th column is not blank and is not "no_fix", it isn't a "QM"
                        isQM = False
                        Exit For
                    End If
                Next

                'Update column 1 to show QM or QA
                With .Cells(startRow, 1)
                    If isQM Then
                        .Value = "QM"
                        .Interior.Color = vbGreen
                    Else
                        .Value = "QA"
                        .Interior.Color = vbRed
                    End If
                End With

                'Point to start of next block
                startRow = endRow + 1
            End If
        Next
    End With

    Application.DisplayAlerts = True
    Application.ScreenUpdating = True
End Sub