none
Concatenate all Cells above a cell RRS feed

  • Question

  • I have the following VBA code that Hans Vogelaar MVP most graciously gave me. I want to add something to the code and I am not sure how to add it. I want all of the cells above the "Amount" label that was inserted in column "F" in the row the VBA code spits out to be concatenated. In other words I want "Amount" to be replaced with all of the words in the cells above it in the same column "F". The following is an example of what is in the cells above:

    F1.............

    F2.............Corporate

    F3.............Total

    F4.............SEG:011

    F5.............

    F6.............

    .

    F?............."Amount" which was inserted using the VBA code below.

    I want to do this for columns F-Z.

    Dim r As Long
        r = 1
        Do Until Range("A" & r).Value <> ""
            r = r + 1
        Loop
        Range("A" & r).EntireRow.Insert
        Range("A" & r).Value = "Line with Description"
        Range("B" & r).Value = "Primary Key"
        Range("C" & r).Value = "Line"
        Range("D" & r).Value = "RUs"
        Range("E" & r).Value = "Name"
        Range("F" & r).Value = "Amount"
        Range("G" & r).Value = "A"
        Range("H" & r).Value = "B"
        Range("I" & r).Value = "C"
        Range("J" & r).Value = "D"
        Range("K" & r).Value = "E"
        Range("L" & r).Value = "F"
        Range("M" & r).Value = "G"
        Range("N" & r).Value = "H"
        Range("O" & r).Value = "I"
        Range("P" & r).Value = "J"
        Range("Q" & r).Value = "K"
        Range("R" & r).Value = "L"
        Range("S" & r).Value = "M"
        Range("T" & r).Value = "N"
        Range("U" & r).Value = "O"
        Range("V" & r).Value = "P"
        Range("W" & r).Value = "Q"
        Range("X" & r).Value = "R"
        Range("Y" & r).Value = "S"
        Range("Z" & r).Value = "T"

    Tuesday, April 2, 2013 6:34 PM

Answers

  • Try this macro:

    Sub InsertAndFillRow()
        Dim r As Long
        Dim c As Long
        Dim arrText(6 To 26) As String
        r = 1
        Do Until Range("A" & r).Value <> ""
            For c = 6 To 26
                If Cells(r, c).Value <> "" Then
                    arrText(c) = arrText(c) & " " & Cells(r, c).Value
                End If
            Next c
            r = r + 1
        Loop
        Range("A" & r).EntireRow.Insert
        Range("A" & r).Value = "Line with Description"
        Range("B" & r).Value = "Primary Key"
        Range("C" & r).Value = "Line"
        Range("D" & r).Value = "RUs"
        Range("E" & r).Value = "Name"
        For c = 6 To 26
            Cells(r, c).Value = Trim(arrText(c))
        Next c
    End Sub


    Regards, Hans Vogelaar

    Hi

    To add to this, you can try the following example for pasting the contents back

    Range("E6:E26").Value  = Application.WorksheetFunction.Transpose(arrText)

    Cheers

    Sgasyr


    http://www.vbadud.blogspot.com http://www.dotnetdud.blogspot.com

    Wednesday, April 3, 2013 10:39 AM

All replies

  • Try this macro:

    Sub InsertAndFillRow()
        Dim r As Long
        Dim c As Long
        Dim arrText(6 To 26) As String
        r = 1
        Do Until Range("A" & r).Value <> ""
            For c = 6 To 26
                If Cells(r, c).Value <> "" Then
                    arrText(c) = arrText(c) & " " & Cells(r, c).Value
                End If
            Next c
            r = r + 1
        Loop
        Range("A" & r).EntireRow.Insert
        Range("A" & r).Value = "Line with Description"
        Range("B" & r).Value = "Primary Key"
        Range("C" & r).Value = "Line"
        Range("D" & r).Value = "RUs"
        Range("E" & r).Value = "Name"
        For c = 6 To 26
            Cells(r, c).Value = Trim(arrText(c))
        Next c
    End Sub


    Regards, Hans Vogelaar

    • Proposed as answer by Shasur Wednesday, April 3, 2013 10:37 AM
    Tuesday, April 2, 2013 7:31 PM
  • Try this macro:

    Sub InsertAndFillRow()
        Dim r As Long
        Dim c As Long
        Dim arrText(6 To 26) As String
        r = 1
        Do Until Range("A" & r).Value <> ""
            For c = 6 To 26
                If Cells(r, c).Value <> "" Then
                    arrText(c) = arrText(c) & " " & Cells(r, c).Value
                End If
            Next c
            r = r + 1
        Loop
        Range("A" & r).EntireRow.Insert
        Range("A" & r).Value = "Line with Description"
        Range("B" & r).Value = "Primary Key"
        Range("C" & r).Value = "Line"
        Range("D" & r).Value = "RUs"
        Range("E" & r).Value = "Name"
        For c = 6 To 26
            Cells(r, c).Value = Trim(arrText(c))
        Next c
    End Sub


    Regards, Hans Vogelaar

    Hi

    To add to this, you can try the following example for pasting the contents back

    Range("E6:E26").Value  = Application.WorksheetFunction.Transpose(arrText)

    Cheers

    Sgasyr


    http://www.vbadud.blogspot.com http://www.dotnetdud.blogspot.com

    Wednesday, April 3, 2013 10:39 AM