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.
Code:
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
Bookmarks