How to write a macro for multiple response fields

Question

I have an excel spreadsheet that has various values in a column. Some are single response, some are multiple response, and some are n/a. I need to write a macro where if there is 1 value in column A then put a "1" in column B. If there are 2 values in Column A then put two "1"'s in column B, if 3 values in column A, then put 3 "1''s in column B ect... If there is an n/a, just skip that row. Here is what my raw data looks like in the first image.

.

Answer 1

You can loop through each row, check the cell in column A, and write the appropriate number of 1’s in column B. For multiple-response cells, this assumes the values are separated by either commas, semicolons, or spaces—adjust the Split delimiter as needed.

Here is a sample VBA macro:

Sub FillOnesBasedOnResponses()

    Dim ws As Worksheet
    Dim lastRow As Long
    Dim i As Long
    Dim cellValue As String
    Dim parts As Variant
    
    Set ws = ThisWorkbook.Sheets("Sheet1")   'change sheet name if needed
    lastRow = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row
    
    For i = 1 To lastRow
        cellValue = Trim(ws.Cells(i, "A").Value)
        
        If LCase(cellValue) = "n/a" Or cellValue = "" Then
            'skip
        Else
            parts = Split(cellValue, " ")
            ws.Cells(i, "B").Value = WorksheetFunction.CountA(parts)
        End If
    Next i

End Sub

If your multiple responses are separated by commas, replace:

parts = Split(cellValue, " ")

with:

parts = Split(cellValue, ",")

This writes 1, 2, 3, ... depending on how many values appear in column A, while skipping n/a.

---

If the above response helps answer your question, remember to "Accept Answer" so that others in the community facing similar issues can easily find the solution. Your contribution is highly appreciated.

hth

Marcin

Answer 2

Count of Substrings

Excel Formula (Single Cell)

=IF(LEN(A2)=0,"",IF(A2="n/a","",REPT("1",LEN(A2)-LEN(SUBSTITUTE(A2,CHAR(10),))+1)))

Excel Formula (MS365)

=LET(a,A2:A6,r,"1",n,"n/a",d,CHAR(10),
    IF(LEN(a)=0,"",IF(a=n,"",REPT(r,LEN(a)-LEN(SUBSTITUTE(a,d,))+1))))

VBA

Sub GenerateResponseIds()
    
    ' Define constants.
    
    ' Both
    Const SHEET_NAME As String = "Sheet1"
    ' Source
    Const S_TOP_CELL As String = "A2"
    Const S_STRING_DELIMITER As String = vbLf
    Const S_NA_STRING As String = "n/a"
    ' Destination
    Const D_COLUMN As String = "B"
    Const D_REPEAT_COUNT_STRING As String = "1"
    ' Clears the excessive rows when the data previously had more rows than now.
    ' If the number of rows will only grow, set it to 'False'.
    Const D_OK_TO_CLEAR_COLUMN_TO_BOTTOM As Boolean = True

    ' Reference the workbook.
    Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
    ' If it's not, reference it by its name or use 'ActiveWorkbook' instead.
    
    ' Reference the worksheet.
    Dim ws As Worksheet: Set ws = wb.Sheets(SHEET_NAME)
    
    ' Reference the single-column ranges and retrieve their number of rows.
    
    Dim srg As Range, drg As Range, RowsCount As Long
    
    With ws.Range(S_TOP_CELL)
        RowsCount = ws.Cells(ws.Rows.Count, .Column).End(xlUp).Row - .Row + 1
        If RowsCount < 1 Then Exit Sub ' no data
        Set srg = .Resize(RowsCount)
        Set drg = srg.EntireRow.Columns(D_COLUMN)
    End With
    
    ' Return the source values in a 2D one-based (single-column) array.
    
    Dim sData() As Variant
    
    If RowsCount = 1 Then
        ReDim sData(1 To 1, 1 To 1): sData(1, 1) = srg.Value
    Else
        sData = srg.Value
    End If
    
    ' Define and populate the destination array applying the required logic.
    
    Dim dData() As String: ReDim dData(1 To RowsCount, 1 To 1)
    ' If the ones should be numbers, as a simple fix,
    ' use 'Dim dData() As Variant' instead.
    
    Dim SubStrings() As String, RowString As String
    Dim Row As Long, SubStringsCount As Long
    
    For Row = 1 To RowsCount
        RowString = CStr(sData(Row, 1))
        Select Case True
            Case Len(RowString) = 0 ' is blank
                ' do nothing; corresponding cell will become empty
            Case StrComp(RowString, S_NA_STRING, vbTextCompare) = 0 ' is NA
                ' do nothing; corresponding cell will become empty
                ' If 'n/a' was supposed to be the '#N/A' error, as a simple fix,
                ' use 'Case IsError(sData(Row, 1))' as the first case instead.
            Case Else
                ' Return the substrings in a String array.
                SubStrings = Split(RowString, S_STRING_DELIMITER)
                ' Retrieve the number of elements of the String array.
                SubStringsCount = UBound(SubStrings) + 1
                ' Write the repeating string.
                dData(Row, 1) = String(SubStringsCount, D_REPEAT_COUNT_STRING)
        End Select
    Next Row
    
    ' Optionally, clear the destination column.
    If D_OK_TO_CLEAR_COLUMN_TO_BOTTOM Then
        drg.Resize(ws.Rows.Count - drg.Row + 1).Clear
    End If
    
    ' Populate the destination range.
    drg.Value = dData
    
    ' Inform user.
    MsgBox "Response IDs generated.", vbInformation

End Sub