CODEWITHSUNDEEP
vbaexcel
Daniel Strong
Daniel Strong

Reputation: 213

VBA Combine Multiple columns of data into 1 column

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

Upvotes: 0

Views: 1766

Answers (1)

R3uK
R3uK

Reputation: 14547

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

Upvotes: 1

Related Questions