Macro to take two different counts from a single row

I needed results as in 'Result' column shown in the table below.

X1 Y1 X2 Y2 X3 Y3 X4 Y4 X5 Y5 Result
Req-BX BX Req-EA EACH Req-CA Glove 1 out of 3 Required
Req-BT BOTTLE Req-GL Req-CTN 2 out of 3 Required
Req-PR PAIR Req-BX BOX Req-EA EACH Req-CA CASE 0 out of 4 Required
DZ DOZEN PR PAIR PK 0 out of 0 Required
Req-PK PACK DZ DOZEN PR PAIR PK Req-CA 1 out of 2 Required

I could achieve this with the help of Dan. Here is the script.
Public Sub Stack()

Dim DataSheet As Worksheet
Dim LastRow As Long, LastCol As Long, _
    ResultCol As Long, RowIdx As Long, _
    ResultCol2 As Long, _
    ColIdx As Long, ReqCounter As Long, _
    FoundCounter As Long, _
    Str As String

'assign sheet for easy reference
Set DataSheet = ThisWorkbook.Worksheets("Sheet1")

'define the range for our loops
LastRow = 1003
LastCol = 100 'column CV
ResultCol = 1 'column CW
ResultCol2 = 2 'column CX

'loop through target rows
For RowIdx = 2 To LastRow

    'initialize counters
    ReqCounter = 0
    FoundCounter = 0

    'loop through target columns
    For ColIdx = 5 To LastCol Step 2

        'check to see if the cell contains "Req" and increment as necessary
        If InStr(1, DataSheet.Cells(RowIdx, ColIdx), "REQ", vbTextCompare) > 0 Then
            ReqCounter = ReqCounter + 1
           
        If DataSheet.Cells(RowIdx, ColIdx + 1).Value = "" Then
            FoundCounter = FoundCounter + 1
           
        'check the neighboring cell for a non-blank value and increment as necessary
        If InStr(1, DataSheet.Cells(RowIdx, ColIdx), "REQ", vbTextCompare) > 0 And DataSheet.Cells(RowIdx, ColIdx + 1).Value = "" Then
        Str = Str & ", " & DataSheet.Cells(RowIdx, ColIdx).Value
        End If
        End If
        End If

       

    Next ColIdx

    'write to the result cell
    DataSheet.Cells(RowIdx, ResultCol) = FoundCounter & " out of " & ReqCounter & " Required"
    DataSheet.Cells(RowIdx, ResultCol2) = Application.WorksheetFunction.Substitute(Str, "REQUIRED-", "")
    Str = ""
Next RowIdx

MsgBox ("Completed")
End Sub

No comments:

Post a Comment