VBA to add a combined string value to a certain column, cell if it meets the required value in the destination sheet

Question

I need this to add the combinedvalue to the destination to certain columns and then leave cells empty if they do not meet the criteria. Currently it adds each combinedvalue to the destination starting at A1 and continues to loop adding to each 4 columns. It does this perfectly. I need this to add to certain columns. In the source, column C will always contain A,B,C,D and need them to match the destination columns or leave the cell empty and continue until it finds a column it can go and continue to loop through the rows.

Sub CreateNewWorkbook()
    Dim srcWorkbook As Workbook
    Dim destWorkbook As Workbook
    Dim srcSheet As Worksheet
    Dim destSheet As Worksheet
    Dim newWorkbookName As String
    Dim destRow As Long
    Dim destCol As Long
    Dim lastRow As Long
    Dim i As Long
    Dim row As Long
    Dim combinedValue As String

    Set srcWorkbook = ThisWorkbook
    Set srcSheet = srcWorkbook.Sheets("Test")

    newWorkbookName = "TestCompleted"

    Set destWorkbook = Workbooks.Add

    Set destSheet = destWorkbook.Sheets(1)

    destRow = 1
    destCol = 1

    destSheet.Name = "TestDest"

    lastRow = srcSheet.Cells(srcSheet.Rows.Count, "A").End(xlUp).row

    destRow = 1
    For row = 2 To lastRow

        combinedValue = "This" & "-" & _
                        srcSheet.Cells(row, "A").Value & "-" & _
                        srcSheet.Cells(row, "B").Value & "-" & _
                        srcSheet.Cells(row, "C").Value & "-" & _
                        srcSheet.Cells(row, "D").Value

        destSheet.Cells(destRow, destCol).Value = combinedValue

        destCol = destCol + 1

        If destCol > 4 Then
            destCol = 1
            destRow = destRow + 1
        End If
    Next row

    With destSheet.Range("A:D")
        .HorizontalAlignment = xlCenter
    End With

    destSheet.Columns("A:D").AutoFit

    Dim cell As Range
    For Each cell In destSheet.UsedRange
        If InStr(1, cell.Value, "YES") > 0 Then
            cell.Interior.Color = RGB(0, 0, 255) ' Blue
            cell.Font.Color = RGB(255, 255, 255) ' White
        ElseIf InStr(1, cell.Value, "NO") > 0 Then
            cell.Interior.Color = RGB(255, 0, 0) ' Red
            cell.Font.Color = RGB(255, 255, 255) ' White
        End If
    Next cell

    destWorkbook.SaveAs Filename:=ThisWorkbook.Path & "\" & newWorkbookName & ".xlsx"

    MsgBox "New workbook created and saved as " & newWorkbookName & ".xlsx"
End Sub

        

ColumnA	ColumnB	ColumnC	ColumnD
1	1	A	YES
1	1	B	YES
1	1	C	YES
1	1	D	YES
2	1	A	YES
2	1	B	YES
3	1	A	YES
3	1	B	YES
3	1	C	YES
3	1	D	YES
4	1	C	YES
4	1	D	YES
5	1	B	YES
6	1	A	NO
6	1	B	NO
6	1	C	NO
6	1	D	NO
7	1	A	NO
7	1	B	NO
8	1	A	NO
8	1	B	NO
8	1	C	NO
8	1	D	NO
9	1	C	NO
9	1	D	NO
10	1	B	NO

I've tried to modify with some If by using the source column and with the combinedvalue and Do functions. But to no avail. Attached image shows what I'm trying to acheive.

Answer 1

• Adjust destRow and destCol before updating cell

Option Explicit
Sub Demo()
    Dim srcSheet As Worksheet, destSheet As Worksheet
    Dim destCol As Long, destRow As Long, iRow  As Long, combinedValue As String, iCol As Long
    Set srcSheet = Sheets("Sheet1")
    Set destSheet = Sheets("Sheet2")
    destSheet.Cells.Clear
    destRow = 1: destCol = 1
    ' loop through data row
    For iRow = 1 To srcSheet.Range("A1").End(xlDown).Row
        ' get column index
        iCol = Cells(1, srcSheet.Cells(iRow, "C").Value).Column
        combinedValue = "This" & "-" & _
                        srcSheet.Cells(iRow, "A").Value & "-" & _
                        srcSheet.Cells(iRow, "B").Value & "-" & _
                        srcSheet.Cells(iRow, "C").Value & "-" & _
                        srcSheet.Cells(iRow, "D").Value
        If iCol < destCol Then ' start a new line
            destCol = iCol
            destRow = destRow + 1
        ElseIf iCol > destCol And iCol <= 4 Then ' jump to the matching column
            destCol = iCol
        End If
        ' populate output
        destSheet.Cells(destRow, destCol).Value = combinedValue
        If destCol = 4 Then
            destCol = 1
            destRow = destRow + 1
        Else
            destCol = destCol + 1
        End If
    Next iRow
End Sub