Shifting and combining columns using VBA

[texas979]

Hi, I have VERY LITTLE knowledge in VBA. However, I need to complete this task, and it must be done in VBA.

I have attached the data below. What I am trying to accomplish is hard to explain if you do not have the data in front of you.

DATA: Data.xlsx

What I am trying to do is this:

I want to align all the "Amount and Kind of Material Used" cells into the same column. In this small data, the LAST column with "Amount and Kind of Material Used" is column R. So ideally, I want all the other "Amount and kind of material used" to shift over to column R as well. Keep in mind that this should move all other cells after "Amount and Kind of Material Used" as well.

Once this is completed, I want to COMBINE ALL CELLS after the "Amount and Kind of Material Used" column into one cell with an underscore in between.

can someone PLEASE help me with this?

or help me START the code. I'm on Google reading VBA for dummies and it really isn't helping.

Thanks.

[millz]

Hi texas, you can try this code below. I have written it as close as possible to do what you have described, also included some comments.

Sub Align_And_Combine()
    Dim i, k, lastCol, c(), lastData() As Long
    Dim tempStr As String
    lastCol = 1
    i = 1
    'Reading data (rows)
    Do While Cells(i, 1) <> ""
        k = 1
        ReDim Preserve lastData(i)
        'Reading data (columns)
        Do While Cells(i, k) <> ""
            lastData(i) = k 'last column number with data
            If InStr(1, Cells(i, k).Value, "Amount and kind", vbTextCompare) > 0 Then
                If k > lastCol Then lastCol = k 'last column number that is "Amount and kind of material"
                ReDim Preserve c(i)
                c(i) = k 'save every row's "Amount and kind of material" column number
            End If
            k = k + 1
        Loop
        i = i + 1
    Loop
    i = 1
    'Arranging and combining
    Do While i <= UBound(c)
        'if this row's "Amount and kind of material" column number is not the same as the furthest, move the data accordingly
        If c(i) <> lastCol Then
            Range(Cells(i, 1), Cells(i, lastData(i))).Cut Destination:=Cells(i, lastCol - c(i) + 1)
        End If
        k = 1
        tempStr = ""
        'Read and combine data after "Amount and kind of material" column
        Do While Cells(i, lastCol + k) <> ""
            tempStr = tempStr & Cells(i, lastCol + k) & "_"
            k = k + 1
        Loop
        tempStr = Left(tempStr, Len(tempStr) - 1) 'remove the last underscore
        Range(Cells(i, lastCol + 1), Cells(i, lastCol + k)).ClearContents 'clears the cells
        Cells(i, lastCol + 1) = tempStr 'write the combined data
        i = i + 1
    Loop
End Sub