Macro to copy cells from different rows into 1 row based on a criteria and delete blanks/shift cells left

Question

My knowledge in macro is limited to recording steps, I have not learned how to write/edit codes yet. I need help writing a macro that will copy cells from a certain row based on the first column's value and paste to a new tab, then remove blanks/shift cells left and copy data from the next row to the next cell after the last entry of the first set of data that was transferred.

I need all the data in the same row if Column A entry is not 1. Anything labeled with 1 on Column A of the data_sheet indicates that the cells in the row should be copied to a new row in the output_sheet

From this (data_sheet): http://prntscr.com/348w2b

To this (output_sheet): http://prntscr.com/348w4k

I could do this manually but I'm working with over 100k rows

Any help would be very much appreciated!

Thanks!

Answer 1

Try this, where initially the active sheet is your data grid:

Sub ReArrangeSheet()

Dim yCounter As Long, xCounter As Long
Dim LastCol As Long, LastRow As Long
Dim OutRow As Long, ColCounter As Long
Dim OutSheet As Worksheet, DataSheet As Worksheet

'name the active sheet so we can reference it easily
ActiveSheet.Name = "Data"
Set DataSheet = Worksheets("Data")

'find the last row and and last col to identify the ends
'of our loops
LastCol = DataSheet.Cells.Find("*", SearchOrder:=xlByColumns, SearchDirection:=xlPrevious).Column
LastRow = DataSheet.Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row

'create an output worksheet
Worksheets.Add(After:=Worksheets(1)).Name = "Output"
Set OutSheet = Worksheets("Output")

'start looping through the checker column
OutRow = 0
For yCounter = 2 To LastRow

    If DataSheet.Cells(yCounter, 1) = 1 Then 'start new row on output sheet
        OutRow = OutRow + 1
        ColCounter = 1 'initialize ColCounter everytime a new row starts
    End If

    'start looping through data grid
    For xCounter = 2 To LastCol

        If DataSheet.Cells(yCounter, xCounter) <> "" Then 'write to output sheet
            OutSheet.Cells(OutRow, ColCounter) = DataSheet.Cells(yCounter, xCounter)
            ColCounter = ColCounter + 1
        End If

    Next xCounter

Next yCounter

End Sub