VBA Combine Multiple columns of data into 1 column - vba

Question

I am still newer to VBA and have been trying everything I can think of to get this accomplished before asking for help, but cannot figure it out.
I have an excel file with multiple tabs. I am only concerned with 2 of them. I need to combine rows based off of their values not being blank from tab "Roadmap" into column B on tab "PPPP". The code I have will do that for the first set of data, but then replaces that data with the second set.
Sub Move_PPPP()
Sheets("PPPP").Select
Rows("2:1000").Select
Selection.ClearContents
Dim rowCount2 As Long, shtSrc As Worksheet
Dim shtDest As Worksheet
Dim rng2 As Range
Dim currentRow As Long
Set shtSrc = Sheets("Roadmap")
Set shtDest = Sheets("PPPP")
rowCount2 = shtSrc.Cells(Rows.Count, "C").End(xlUp).Row
Set rng2 = shtSrc.Range("C6:C" & rowCount2)
currentRow = 2
For Each cell2 In rng2.Cells
If cell2.Value <> "" Then
shtDest.Range("B" & currentRow).Value2 = " " & cell2.Text & " - " & cell2.Offset(0, 10).Text
shtDest.Range("B" & currentRow).Value2 = " " & cell2.Text & " - " & cell2.Offset(0, 11).Text
shtDest.Range("B" & currentRow).Value2 = " " & cell2.Text & " - " & cell2.Offset(0, 12).Text
currentRow = currentRow + 1
ElseIf cell2.Value = "" Then
End If
Next cell2
End Sub
I have tried to add a range for my destination sheet, but doing that is only giving me 9 rows of the last row of data from tab "Roadmap"
Sub Move_PPPP()
Sheets("PPPP").Select
Rows("2:1000").Select
Selection.ClearContents
Dim rowCount2 As Long, shtSrc As Worksheet
Dim columnCount As Long
Dim shtDest As Worksheet
Dim rng2 As Range
Dim rng As Range
Dim currentRow As Long
Set shtSrc = Sheets("Roadmap")
Set shtDest = Sheets("PPPP")
rowCount2 = shtSrc.Cells(Rows.Count, "C").End(xlUp).Row
columnCount = shtDest.Cells(Columns.Count, "B").End(xlUp).Row
Set rng2 = shtSrc.Range("C6:C" & rowCount2)
Set rng = shtDest.Range("B2:B" & columnCount & currentRow)
currentRow = 2
For Each cell2 In rng2.Cells
If cell2.Value <> "" Then
rng.Value = " " & cell2.Text & " - " & cell2.Offset(0, 10).Text
currentRow = currentRow + 1
ElseIf cell2.Value = "" Then
End If
Next cell2
End Sub
Sample Data
Roadmap Tab
Column: C D E F G H I J K L M
Headers: Project Status Open Closed Name P1 P2 P3 P4 P5 P6
Row 1: FISMA New Yes No Albert na na na na New Day Old Data
Row 2: QRD Closed No Yes Albert na na na na na Closed
Desired Outcome. Combine Column C with Column M when M <> blank, loop through entire row and put that data in column B of PPPP tab. Then combine column C with N when N <> blank and put that on PPPP tab, column B under the data from column M.
PPPP Tab
Cell B2
FISMA - New Day
Cell B4
FISMA - Old Data
QRD - Closed
SOLUTION:
Sub Move_PPPP()
Sheets("PPPP").Select
Rows("2:1000").Select
Selection.ClearContents
Dim rowCount2 As Long, shtSrc As Worksheet
Dim shtDest As Worksheet
Dim rng2 As Range
Dim currentRow As Long
Set shtSrc = Sheets("Roadmap")
Set shtDest = Sheets("PPPP")
rowCount2 = shtSrc.Cells(Rows.Count, "C").End(xlUp).Row
Set rng2 = shtSrc.Range("C6:C" & rowCount2)
currentRow = shtDest.Range("A" & Rows.Count).End(xlUp).Row
For Each cell2 In rng2.Cells
If cell2.Value2 <> "" Then
shtDest.Range("A" & currentRow).Value2 = " " & cell2.Text & " - " & cell2.Offset(0, 9).Text
currentRow = currentRow + 1
ElseIf cell2.Value = "" Then
End If
Next cell2
Set rng2 = shtSrc.Range("C6:C" & rowCount2)
currentRow = shtDest.Range("A" & Rows.Count).End(xlUp).Row + 1
For Each cell2 In rng2.Cells
If cell2.Value2 <> "" Then
shtDest.Range("A" & currentRow + 1).Value2 = " " & cell2.Text & " - " & cell2.Offset(0, 10).Text
currentRow = currentRow + 1
ElseIf cell2.Value = "" Then
End If
Next cell2
Set rng2 = shtSrc.Range("C6:C" & rowCount2)
currentRow = shtDest.Range("A" & Rows.Count).End(xlUp).Row + 1
For Each cell2 In rng2.Cells
If cell2.Value2 <> "" Then
shtDest.Range("A" & currentRow + 1).Value2 = " " & cell2.Text & " - " & cell2.Offset(0, 11).Text
currentRow = currentRow + 1
ElseIf cell2.Value = "" Then
End If
Next cell2
Set rng2 = shtSrc.Range("C6:C" & rowCount2)
currentRow = shtDest.Range("A" & Rows.Count).End(xlUp).Row + 1
For Each cell2 In rng2.Cells
If cell2.Value2 <> "" Then
shtDest.Range("A" & currentRow + 1).Value2 = " " & cell2.Text & " - " & cell2.Offset(0, 12).Text
currentRow = currentRow + 1
ElseIf cell2.Value = "" Then
End If
Next cell2
End Sub

Answer 1

On the first version, try this :
Sub Move_PPPP()
Sheets("PPPP").Select
Rows("2:1000").Select
Selection.ClearContents
Dim rowCount2 As Long, shtSrc As Worksheet
Dim shtDest As Worksheet
Dim rng2 As Range
Dim currentRow As Long
Set shtSrc = Sheets("Roadmap")
Set shtDest = Sheets("PPPP")
rowCount2 = shtSrc.Cells(Rows.Count, "C").End(xlUp).Row
Set rng2 = shtSrc.Range("C6:C" & rowCount2)
currentRow = shtDest.Range("B" & Rows.Count).End(xlUp).Row
For Each cell2 In rng2.Cells
If cell2.Value <> "" Then
shtDest.Range("B" & currentRow).Value2 = " " & cell2.Text & " - " & cell2.Offset(0, 10).Text
shtDest.Range("B" & currentRow + 1).Value2 = " " & cell2.Text & " - " & cell2.Offset(0, 11).Text
shtDest.Range("B" & currentRow + 2).Value2 = " " & cell2.Text & " - " & cell2.Offset(0, 12).Text
currentRow = currentRow + 1
ElseIf cell2.Value = "" Then
End If
Next cell2
Set rng2 = shtSrc.Range("D6:D" & rowCount2)
currentRow = shtDest.Range("B" & Rows.Count).End(xlUp).Row + 1
For Each cell2 In rng2.Cells
If cell2.Value <> "" Then
shtDest.Range("B" & currentRow).Value2 = " " & cell2.Text & " - " & cell2.Offset(0, 10).Text
shtDest.Range("B" & currentRow + 1).Value2 = " " & cell2.Text & " - " & cell2.Offset(0, 11).Text
shtDest.Range("B" & currentRow + 2).Value2 = " " & cell2.Text & " - " & cell2.Offset(0, 12).Text
currentRow = currentRow + 1
ElseIf cell2.Value = "" Then
End If
Next cell2
End Sub