Macro to move data from one cell to another where unique identifier changes

**boothyuk123** · 10-19-2012, 04:39 PM

I am looking for a Macro that will enable me to move data from cells on the row below to the cells directly above upon the change of a unique identifier (CRN). This is probably a little confusing so I have attached a copy of the data that I am working with along with the desired output. I am looking to move the textbook information on to the same line as the course information rather than having it all on separate lines. At each change in CRN the next blank lines (column A) would be moved to the appropriate course.

The attachment only contains a few courses, I can't do this manually given there are about 12000 records in total in my master spreadsheet. Unfortunately this is just how the data is extracted from the system.

Any help would be greatly appreciated.

Thanks

Chris

**mrice** · 10-19-2012, 05:12 PM

Try this

Sub Test()
For N = Cells(Rows.Count, 7).End(xlUp).Row To 3 Step -1
    If Cells(N, 1) = "" Then
        If Cells(N - 1, 7) = "" Then
            Range(Cells(N, 7), Cells(N, 7).End(xlToRight)).Cut Destination:=Cells(N - 1, 7)
        Else
            Range(Cells(N, 7), Cells(N, 7).End(xlToRight)).Cut Destination:=Cells(N - 1, 7).End(xlToRight).Offset(0, 1)
        End If
        Rows(N).Delete
    End If
Next N
End Sub

Open up the VBA editor by hitting ALT F11

Insert a new module by hitting Insert - Module

Paste the macro into the empty sheet

Hit ALT F11 to get back to the worksheet.

Run the macro by going to tools-macro in Excel 2003 or the view ribbon in Excel 2007/2010.

**srinivassurapareddi** · 10-19-2012, 05:32 PM

Hi ,

I made a serious effort on this .. I have kept a Button1 in sheet "Sheet1" , output shall be derived in sheet2

Sub Main()
Dim i As Integer, c As Integer, p As Integer, T As String, t1 As Integer
p = 2
i = 2
Do While i < 13
    x = Cells(i, 1).Value
        If x <> BLANK Then
            c = 1
            
                Do While c < 14
                If ThisWorkbook.Sheets("Sheet1").Cells(i, c).Value <> BLANK Then
                ThisWorkbook.Sheets("Sheet2").Cells(p, c).Value = ThisWorkbook.Sheets("Sheet1").Cells(i, c).Value
                End If
                If ThisWorkbook.Sheets("Sheet1").Cells(i, c).Value = BLANK Then
                T = ThisWorkbook.Sheets("Sheet1").Cells(i, c).Value
                t1 = i
                Do While T = BLANK
                t1 = t1 + 1
                T = ThisWorkbook.Sheets("Sheet1").Cells(t1, c).Value
                Loop
                
                ThisWorkbook.Sheets("Sheet2").Cells(p, c).Value = T
                End If
                c = c + 1
                Loop
            p = p + 1
        End If
    i = i + 1
Loop

End Sub

Hope this would help you !

Please rate if it works !