Excel VBA - Shift data across multiple columns to a single column

Question

I have a macro right now that pulls data from a different sheet into a new sheet, then formats the data into a form I can use. The issue I have is that some of the PNs that I pull from the other sheet are in different cells for ease of viewing. (For example, the top level PN is in cell C2 and any parts that are a part of the part in C2 may be listed in D3, to show it's a sub-part).

I need code that will shift all PNs across varying columns into a single column. Once all PNs are moved, the other columns should be deleted (D through F). The data ranges from column C to F. Depending on the table the macro pulls data from, the length of the data varies. The macro will need to be able to handle this.

Here's an example of what my sheet looks like after my macro runs:

I'm trying to check column C for empty rows. If say C3 is empty, I then want to check D3 for text. If there is text, I want text in D3 to move to C3. If there is no text, check E3. Same process repeated. From what I've found online, I have this code so far (however, it doesn't run properly in my macro)...

'Copy PNs that are out of line and paste them in the correct column
Dim N As Long, i As Long, j As Long

Set ws1 = Worksheets("KDLSA")

N = ws1.Cells(Rows.Count, "C").End(xlUp).Row
j = 4

For Each cell In Range("D2:F" & ws1.Cells(Rows.Count, "F").End(xlUp).Row)


    If cell.Value = "" Then 'if cell C is blank, I want to shift the text to fill column C
        ws1.Range("C" & j).Value = ws1.Range("D" & cell.Row).Value 'copy PN in column E to column D - this needs to be more robust to cover my range of columns rather than just D and E
        j = j + 1
    End If


Next cell

Any help is appreciated.

Answer 1

Change your "For" block to:

With ws1.UsedRange
    lastRow = .Rows(.Rows.Count).Row
End With
For Each cell In Range("C2:C" & lastRow)
    If cell.Value = "" Then
       thisRow = cell.Row
       For Each horCell In Range(Cells(thisRow, "D"), Cells(thisRow, "F"))
            If Not horCell.Value = "" Then
                cell.Value = horCell.Value
                Exit For
            End If
       Next horCell

    End If


Next cell
Range("D:F").EntireColumn.Delete

By cycling only through column C, you can loop through D-F only if C is blank, and when you find the one with data, it puts it in C.

If you also need dynamic range on the number of columns, then do:

With ws1.UsedRange
    lastRow = .Rows(.Rows.Count).Row
    lastColumn = .Columns(.Columns.Count).Column
End With
For Each cell In Range("C2:C" & lastRow)
    If cell.Value = "" Then
       thisRow = cell.Row
       For Each horCell In Range(Cells(thisRow, "D"), Cells(thisRow, lastColumn))
            If Not horCell.Value = "" Then
                cell.Value = horCell.Value
                Exit For
            End If
       Next horCell

    End If


Next cell
Range(Cells(2, "D"), Cells(2, lastColumn)).EntireColumn.Delete

Or with a correct lastRow in your for loop "to" range, change your code to

If Not cell = "" then
     ws1.range ("C" & cell.Row).Value = cell.Value
 End if

You are looping through columns D-F, so "cell" is a cell in that range, not in column C. You therefore want to test for the ones that are NOT empty and then put their values in the corresponding cell in column C. :-)

Answer 2

As Tehscript mentioned you dont need a macro. If you nevertheless want to use a macro (maybe your real case is more complex than the example) here is a starting point for you.

The example below will shift the cells only once. So you might want to execute the loop several times. (You could also loop over the rowIndex and use a while loop for each row.)

The code could be further refactored but I hope this way it is easy to read.

Sub ShiftCells()


Dim myWorkSheet As Worksheet
Set myWorkSheet = Worksheets("Tabelle1")

Dim maxRowIndex As Long
maxRowIndex = GetMaxRowIndex(myWorkSheet)

Dim rowIndex As Long
Dim columnIndex As Long

Dim leftCell As Range
Dim rightCell As Range

For Each Cell In Range("C2:F" & maxRowIndex)
    If Cell.Value = "" Then
       shiftedCell = True
       rowIndex = Cell.Row
       columnIndex = Cell.Column

       Set leftCell = myWorkSheet.Cells(rowIndex, columnIndex)
       Set rightCell = myWorkSheet.Cells(rowIndex, columnIndex + 1)

       leftCell.Value = rightCell.Value
       rightCell.Value = ""

    End If


Next Cell


End Sub

Function GetMaxRowIndex(ByVal myWorkSheet As Worksheet) As Long
    Dim numberofRowsInColumnC As Long
    numberofRowsInColumnC = myWorkSheet.Cells(Rows.Count, "C").End(xlUp).Row

    Dim numberofRowsInColumnD As Long
    numberofRowsInColumnD = myWorkSheet.Cells(Rows.Count, "D").End(xlUp).Row

    Dim numberofRowsInColumnE As Long
    numberofRowsInColumnE = myWorkSheet.Cells(Rows.Count, "E").End(xlUp).Row

    Dim numberofRowsInColumnF As Long
    numberofRowsInColumnF = myWorkSheet.Cells(Rows.Count, "F").End(xlUp).Row

    Dim maxNumberOfRows As Long
    maxNumberOfRows = WorksheetFunction.Max(numberofRowsInColumnC, _
                                                numberofRowsInColumnD, _
                                                numberofRowsInColumnE, _
                                                numberofRowsInColumnF _
                                                )
    GetMaxRowIndex = maxNumberOfRows
End Function