Question

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

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

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

我有大约5000行的数据

Additional conditions

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

1.另外还有质量管理和质量保证：如果值=“ST”，则检查G列如果值= 0

，则检查H列

2.QA

检查C列，如果值=“LM没有TC”，请检查D列中的if value =“no state”检查E列，如果value =“No IPIS”，如果有的话 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

以下代码将执行您想要的合并，如果我理解您在问题的第二部分中的含义，则将第一列设置为＆＃34; QM＆＃34; （如果第四列绝不是空白或＆＃34; no_fix＆＃34;）或＆＃34; QA＆＃34;。

代码假设您将使用InputBox选择包含四列的范围，第一列是包含＆＃34; QM＆＃34;的列。或者＆＃34; QA＆＃34;，第二个是你的＆＃34; Req＆＃34;专栏，第四个是你的＆＃34;州＆＃34;柱。（代码永远不会查看第三列中的内容。）

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

Excel VBA - 如果列中的值等于

1 个答案: