Code to put multiple rows of data into one row.

F

FROGGER24

Well-known Member
Joined
May 22, 2004
Messages
704
Office Version
  1. 2013
  2. 2010
Platform
  1. Windows
I need to take up to four rows of data per PO number and place in seperate columns.
I have created an example of what the data looks like and the desired results below. Once all of the rows have been moved into the right column, I will need to delete the rows with a zero in column C.
I think what I am looking for is away to create a flat file.
Excel Workbook
BCDEFGHI
1Polot NumBarge St dVessel 1Vessel 2Vessel 3Vessel 4
259788213352427/19/2011apple1
359788203352427/19/2011apple2
460065013422807/16/2011pear1
560065003430907/9/2011pear2
660065003430907/9/2011pear3
760177713448317/12/2011orange1
860177703448317/12/2011orange2
960177703448327/17/2011orange3
1060177703448327/17/2011orange4
1160181913448367/22/2011test
12
1359788213352427/19/2011apple1apple2
1459788203352427/19/2011apple2
1560065013422807/16/2011pear1pear2pear3
1660065003430907/9/2011pear2
1760065003430907/9/2011pear3
1860177713448317/12/2011orange1orange2orange3orange4
1960177703448317/12/2011orange2
2060177703448327/17/2011orange3
2160177703448327/17/2011orange4
2260181913448367/22/2011test
jULY 2011 ec
Excel 2007

Once Again thanks for any help that is provided!!
 

Excel Facts

How can you turn a range sideways?
Copy the range. Select a blank cell. Right-click, Paste Special, then choose Transpose.
Sort by date Sort by votes
I use the following script to do a similar task to want you want, its' not relevent to your data but gives you an idea of what would happen, however it only leaves the coulmn A value once, try it out on a test book and I can adapt it if you want me too.

If you run the script a second time you must first delete sheets dat1, dat2, dat3

Code: 
Paste the following into 1 module.
 
Sub RUN_THIS_SCRIPT()
Application.ScreenUpdating = False
Application.DisplayAlerts = False
On Error Resume Next
 
MsgBox "WILL WORK FOR 14 COLUMN VALUES ONLY, SO 14 DUPLICATES"
On Error Resume Next
ActiveWorkbook.Sheets.Add after:=ActiveWorkbook.Sheets(ActiveWorkbook.Sheets.Count)
ActiveWorkbook.Sheets(ActiveWorkbook.Sheets.Count).Name = "Dat1"
ActiveWorkbook.Sheets.Add after:=ActiveWorkbook.Sheets(ActiveWorkbook.Sheets.Count)
ActiveWorkbook.Sheets(ActiveWorkbook.Sheets.Count).Name = "Dat2"
ActiveWorkbook.Sheets.Add after:=ActiveWorkbook.Sheets(ActiveWorkbook.Sheets.Count)
ActiveWorkbook.Sheets(ActiveWorkbook.Sheets.Count).Name = "Dat3"
 
Sheets("Sheet1").Select
    Cells.Select
    Selection.Copy
    Sheets("Dat2").Select
    Cells.Select
    ActiveSheet.Paste
    Range("A1").Select
Call duplicates_In_Red
Call MoveRedA
Call MoveRedB
Call MoveRedC
Call MoveRedD
Call MoveRedE
Call MoveRedF
Call MoveRedG
Call MoveRedH
Call MoveRedI
Call MoveRedJ
Call MoveRedK
Call MoveRedL
Call MoveRedM
Call MoveRedN
Call Copy_Data
Call Vlookup_Step
Call NEXT_PART
Call NEXT_PART2
Data3.Hide
Application.DisplayAlerts = False
Application.ScreenUpdating = True
End Sub

paste the following into another module. (It's not all relevent script, I just copied everything from my module, but that doesn't matter)

Code: 
Option Private Module
Sub Vlookup_Step()
Application.ScreenUpdating = False
Sheets("Dat3").Select
    Range("B2").Select
   For I = ActiveSheet.UsedRange.Rows.Count To 1 Step -1
   If Cells(3, 1).Value = "jayejaye" Or IsEmpty(Cells(3, 1)) Then
 
 Exit Sub
 Else
 
Sheets("Dat3").Select
    Range("B2").Select
    Range("B2").Select
        ActiveCell.FormulaR1C1 = "=VLOOKUP(RC1, Dat2!C[-1]:C17, 17, FALSE)"
    Range("C2").Select
    ActiveCell.FormulaR1C1 = "=VLOOKUP(RC1, Dat2!C[-1]:C17, 16, FALSE)"
    Range("D2").Select
    ActiveCell.FormulaR1C1 = "=VLOOKUP(RC1, Dat2!C[-1]:C17, 15, FALSE)"
   Range("E2").Select
    ActiveCell.FormulaR1C1 = "=VLOOKUP(RC1, Dat2!C[-1]:C17, 14, FALSE)"
    Range("F2").Select
    ActiveCell.FormulaR1C1 = "=VLOOKUP(RC1, Dat2!C[-1]:C17, 13, FALSE)"
    Range("G2").Select
    ActiveCell.FormulaR1C1 = "=VLOOKUP(RC1, Dat2!C[-1]:C17, 12, FALSE)"
    Range("H2").Select
    ActiveCell.FormulaR1C1 = "=VLOOKUP(RC1, Dat2!C[-1]:C17, 11, FALSE)"
    Range("I2").Select
    ActiveCell.FormulaR1C1 = "=VLOOKUP(RC1, Dat2!C[-1]:C17, 10, FALSE)"
    Range("J2").Select
    ActiveCell.FormulaR1C1 = "=VLOOKUP(RC1, Dat2!C[-1]:C17, 9, FALSE)"
    Range("K2").Select
    ActiveCell.FormulaR1C1 = "=VLOOKUP(RC1, Dat2!C[-1]:C17, 8, FALSE)"
    Range("L2").Select
    ActiveCell.FormulaR1C1 = "=VLOOKUP(RC1, Dat2!C[-1]:C17, 7, FALSE)"
    Range("M2").Select
    ActiveCell.FormulaR1C1 = "=VLOOKUP(RC1, Dat2!C[-1]:C17, 6, FALSE)"
    Range("N2").Select
    ActiveCell.FormulaR1C1 = "=VLOOKUP(RC1, Dat2!C[-1]:C17, 5, FALSE)"
    Range("O2").Select
    ActiveCell.FormulaR1C1 = "=VLOOKUP(RC1, Dat2!C[-1]:C17, 4, FALSE)"
    Range("P2").Select
    ActiveCell.FormulaR1C1 = "=VLOOKUP(RC1, Dat2!C[-1]:C17, 3, FALSE)"
 
    End If
    Next
    Application.ScreenUpdating = True
    End Sub
 
 
 
Sub Copy_Data()
Application.ScreenUpdating = False
Sheets("Sheet1").Select
    Columns("A:A").Select
    Selection.Copy
    Sheets("Dat1").Select
ActiveSheet.Paste
    Application.CutCopyMode = False
    Selection.Sort Key1:=Range("A1"), Order1:=xlAscending, Header:=xlYes, _
        OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
        DataOption1:=xlSortNormal
    Range("A1").Select
 
 Sheets("Dat2").Select
 Columns("A:A").Select
    Selection.Copy
    Sheets("Dat3").Select
    Columns("A:A").Select
    ActiveSheet.Paste
    Application.CutCopyMode = False
    Selection.Sort Key1:=Range("A2"), Order1:=xlAscending, Header:=xlYes, _
        OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
        DataOption1:=xlSortNormal
    Range("A1").Select
    Application.ScreenUpdating = True
End Sub
 
 
 
 
    Sub NEXT_PART()
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
 
    Range("B2").Select
With ActiveCell
       .AutoFill Destination:=Range(ActiveCell.Offset(, -1), ActiveCell.Offset(, -1).End(xlDown)).Offset(, 1)
   End With
    Range("C2").Select
With ActiveCell
       .AutoFill Destination:=Range(ActiveCell.Offset(, -1), ActiveCell.Offset(, -1).End(xlDown)).Offset(, 1)
   End With
    Range("D2").Select
With ActiveCell
       .AutoFill Destination:=Range(ActiveCell.Offset(, -1), ActiveCell.Offset(, -1).End(xlDown)).Offset(, 1)
   End With
    Range("E2").Select
With ActiveCell
       .AutoFill Destination:=Range(ActiveCell.Offset(, -1), ActiveCell.Offset(, -1).End(xlDown)).Offset(, 1)
   End With
 
     Range("F2").Select
With ActiveCell
       .AutoFill Destination:=Range(ActiveCell.Offset(, -1), ActiveCell.Offset(, -1).End(xlDown)).Offset(, 1)
   End With
 
       Range("G2").Select
With ActiveCell
       .AutoFill Destination:=Range(ActiveCell.Offset(, -1), ActiveCell.Offset(, -1).End(xlDown)).Offset(, 1)
   End With
 
       Range("H2").Select
With ActiveCell
       .AutoFill Destination:=Range(ActiveCell.Offset(, -1), ActiveCell.Offset(, -1).End(xlDown)).Offset(, 1)
   End With
 
       Range("I2").Select
With ActiveCell
       .AutoFill Destination:=Range(ActiveCell.Offset(, -1), ActiveCell.Offset(, -1).End(xlDown)).Offset(, 1)
   End With
 
       Range("J2").Select
With ActiveCell
       .AutoFill Destination:=Range(ActiveCell.Offset(, -1), ActiveCell.Offset(, -1).End(xlDown)).Offset(, 1)
   End With
 
       Range("K2").Select
With ActiveCell
       .AutoFill Destination:=Range(ActiveCell.Offset(, -1), ActiveCell.Offset(, -1).End(xlDown)).Offset(, 1)
   End With
    Range("L2").Select
With ActiveCell
       .AutoFill Destination:=Range(ActiveCell.Offset(, -1), ActiveCell.Offset(, -1).End(xlDown)).Offset(, 1)
   End With
 
       Range("M2").Select
With ActiveCell
       .AutoFill Destination:=Range(ActiveCell.Offset(, -1), ActiveCell.Offset(, -1).End(xlDown)).Offset(, 1)
   End With
 
       Range("N2").Select
With ActiveCell
       .AutoFill Destination:=Range(ActiveCell.Offset(, -1), ActiveCell.Offset(, -1).End(xlDown)).Offset(, 1)
   End With
 
       Range("O2").Select
With ActiveCell
       .AutoFill Destination:=Range(ActiveCell.Offset(, -1), ActiveCell.Offset(, -1).End(xlDown)).Offset(, 1)
   End With
 
       Range("P2").Select
With ActiveCell
       .AutoFill Destination:=Range(ActiveCell.Offset(, -1), ActiveCell.Offset(, -1).End(xlDown)).Offset(, 1)
   End With
 
       Range("Q2").Select
With ActiveCell
       .AutoFill Destination:=Range(ActiveCell.Offset(, -1), ActiveCell.Offset(, -1).End(xlDown)).Offset(, 1)
   End With
   Application.ScreenUpdating = True
    Application.Calculation = xlCalculationAutomatic
   End Sub
 
Sub last_Cell()
Range("a65536").End(xlUp).Offset(1, 0).Select
End Sub
Sub cell_offset()
ActiveCell.Offset(rowOffset:=0, columnOffset:=-1).Activate
End Sub
Sub NEXT_PART2()
    Cells.Select
    Selection.Copy
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    Selection.Replace What:="#N/A", Replacement:="", LookAt:=xlPart, _
        SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
        ReplaceFormat:=False
 
    Application.CutCopyMode = False
    Range("A1").Select
    MsgBox "Process Completed, Your Welcome"
End Sub
 
 
Sub clear_cells()
Sheets("Dat1").Select
Rows("2:2").Select
    Range(Selection, ActiveCell.SpecialCells(xlLastCell)).Select
    Range(Selection, Selection.End(xlToRight)).Select
    Range(Selection, Selection.End(xlDown)).Select
    Range(Selection, Selection.End(xlDown)).Select
    Range(Selection, Selection.End(xlDown)).Select
    Rows("2:65535").Select
    Selection.ClearContents
    Sheets("Dat3").Select
    Cells.Select
    Selection.ClearContents
    Range("A1").Select
    Sheets("Dat2").Select
    Cells.Select
    Selection.ClearContents
    Range("A1").Select
    Sheets("Dat1").Select
    Range("A2").Select
End Sub
Sub MoveRedA()
Application.ScreenUpdating = False
On Error Resume Next
Columns("A:A").Select '    CHANGE COLUMN CODE
Dim R As Range, r1 As Range
Dim cell As Range, cell1 As Range, S As String
Set R = Range(Cells(1, "A"), Cells(Rows.Count, "A").End(xlUp))
 
Columns(2).EntireColumn.Insert     ' CHANGE COLUMN CODE
For Each cell In R
 If cell.Font.ColorIndex = 3 Then
   cell.Copy cell.Offset(0, 1)
   cell.ClearContents
 End If
Next
Columns("B:B").Select     ' CHANGE COLUMN CODE
    Selection.Font.ColorIndex = 1
 
 
End Sub
Sub MoveRedB()
Application.ScreenUpdating = False
 Cells.Select
    Selection.Sort Key1:=Range("B2"), Order1:=xlAscending, Header:=xlYes, _
        OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
        DataOption1:=xlSortNormal
    Range("B1").Select
Call duplicates_In_Red
On Error Resume Next
Columns("B:B").Select     ' CHANGE COLUMN CODE
Dim R As Range, r1 As Range
Dim cell As Range, cell1 As Range, S As String
Set R = Range(Cells(1, "B"), Cells(Rows.Count, "B").End(xlUp)) ' CHANGE COLUMN CODE
 
Columns(3).EntireColumn.Insert     ' CHANGE COLUMN CODE
For Each cell In R
 If cell.Font.ColorIndex = 3 Then
   cell.Copy cell.Offset(0, 1)
   cell.ClearContents
 End If
Next
Columns("C:C").Select     ' CHANGE COLUMN CODE
    Selection.Font.ColorIndex = 1
 
End Sub
 
Sub MoveRedC()
Application.ScreenUpdating = False
Cells.Select
    Selection.Sort Key1:=Range("C2"), Order1:=xlAscending, Header:=xlYes, _
        OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
        DataOption1:=xlSortNormal
    Range("C1").Select
Call duplicates_In_Red
On Error Resume Next
Columns("C:C").Select     ' CHANGE COLUMN CODE
Dim R As Range, r1 As Range
Dim cell As Range, cell1 As Range, S As String
Set R = Range(Cells(1, "C"), Cells(Rows.Count, "C").End(xlUp)) ' CHANGE COLUMN CODE
 
Columns(4).EntireColumn.Insert     ' CHANGE COLUMN CODE
For Each cell In R
 If cell.Font.ColorIndex = 3 Then
   cell.Copy cell.Offset(0, 1)
   cell.ClearContents
 End If
Next
Columns("D:D").Select     ' CHANGE COLUMN CODE
    Selection.Font.ColorIndex = 1
 
End Sub
Sub MoveRedD()
Application.ScreenUpdating = False
Cells.Select
    Selection.Sort Key1:=Range("D2"), Order1:=xlAscending, Header:=xlYes, _
        OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
        DataOption1:=xlSortNormal
    Range("D1").Select
Call duplicates_In_Red
On Error Resume Next
Columns("D:D").Select     ' CHANGE COLUMN CODE
Dim R As Range, r1 As Range
Dim cell As Range, cell1 As Range, S As String
Set R = Range(Cells(1, "D"), Cells(Rows.Count, "D").End(xlUp)) ' CHANGE COLUMN CODE
 
Columns(5).EntireColumn.Insert     ' CHANGE COLUMN CODE
For Each cell In R
 If cell.Font.ColorIndex = 3 Then
   cell.Copy cell.Offset(0, 1)
   cell.ClearContents
 End If
Next
Columns("E:E").Select     ' CHANGE COLUMN CODE
    Selection.Font.ColorIndex = 1
 
End Sub
 
Sub MoveRedE()
Application.ScreenUpdating = False
Cells.Select
    Selection.Sort Key1:=Range("E2"), Order1:=xlAscending, Header:=xlYes, _
        OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
        DataOption1:=xlSortNormal
    Range("E1").Select
Call duplicates_In_Red
On Error Resume Next
Columns("E:E").Select     ' CHANGE COLUMN CODE
Dim R As Range, r1 As Range
Dim cell As Range, cell1 As Range, S As String
Set R = Range(Cells(1, "E"), Cells(Rows.Count, "E").End(xlUp)) ' CHANGE COLUMN CODE
 
Columns(6).EntireColumn.Insert     ' CHANGE COLUMN CODE
For Each cell In R
 If cell.Font.ColorIndex = 3 Then
   cell.Copy cell.Offset(0, 1)
   cell.ClearContents
 End If
Next
Columns("F:F").Select     ' CHANGE COLUMN CODE
    Selection.Font.ColorIndex = 1
 
End Sub
 
Sub MoveRedF()
Application.ScreenUpdating = False
Cells.Select
    Selection.Sort Key1:=Range("F2"), Order1:=xlAscending, Header:=xlYes, _
        OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
        DataOption1:=xlSortNormal
    Range("F1").Select
Call duplicates_In_Red
On Error Resume Next
Columns("F:F").Select     ' CHANGE COLUMN CODE
Dim R As Range, r1 As Range
Dim cell As Range, cell1 As Range, S As String
Set R = Range(Cells(1, "F"), Cells(Rows.Count, "F").End(xlUp)) ' CHANGE COLUMN CODE
 
Columns(7).EntireColumn.Insert     ' CHANGE COLUMN CODE
For Each cell In R
 If cell.Font.ColorIndex = 3 Then
   cell.Copy cell.Offset(0, 1)
   cell.ClearContents
 End If
Next
Columns("G:G").Select     ' CHANGE COLUMN CODE
    Selection.Font.ColorIndex = 1
 
End Sub
Sub MoveRedG()
Application.ScreenUpdating = False
Cells.Select
    Selection.Sort Key1:=Range("G2"), Order1:=xlAscending, Header:=xlYes, _
        OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
        DataOption1:=xlSortNormal
    Range("G1").Select
Call duplicates_In_Red
On Error Resume Next
Columns("G:G").Select     ' CHANGE COLUMN CODE
Dim R As Range, r1 As Range
Dim cell As Range, cell1 As Range, S As String
Set R = Range(Cells(1, "G"), Cells(Rows.Count, "G").End(xlUp)) ' CHANGE COLUMN CODE
 
Columns(8).EntireColumn.Insert     ' CHANGE COLUMN CODE
For Each cell In R
 If cell.Font.ColorIndex = 3 Then
   cell.Copy cell.Offset(0, 1)
   cell.ClearContents
 End If
Next
Columns("H:H").Select     ' CHANGE COLUMN CODE
    Selection.Font.ColorIndex = 1
 
End Sub
Sub MoveRedH()
Application.ScreenUpdating = False
Cells.Select
    Selection.Sort Key1:=Range("H2"), Order1:=xlAscending, Header:=xlYes, _
        OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
        DataOption1:=xlSortNormal
    Range("H1").Select
 
Call duplicates_In_Red
On Error Resume Next
Columns("H:H").Select     ' CHANGE COLUMN CODE
Dim R As Range, r1 As Range
Dim cell As Range, cell1 As Range, S As String
Set R = Range(Cells(1, "H"), Cells(Rows.Count, "H").End(xlUp)) ' CHANGE COLUMN CODE
 
Columns(9).EntireColumn.Insert     ' CHANGE COLUMN CODE
For Each cell In R
 If cell.Font.ColorIndex = 3 Then
   cell.Copy cell.Offset(0, 1)
   cell.ClearContents
 End If
Next
Columns("I:I").Select     ' CHANGE COLUMN CODE
    Selection.Font.ColorIndex = 1
 
End Sub
Sub MoveRedI()
Application.ScreenUpdating = False
Cells.Select
    Selection.Sort Key1:=Range("I2"), Order1:=xlAscending, Header:=xlYes, _
        OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
        DataOption1:=xlSortNormal
    Range("I1").Select
Call duplicates_In_Red
On Error Resume Next
Columns("I:I").Select     ' CHANGE COLUMN CODE
Dim R As Range, r1 As Range
Dim cell As Range, cell1 As Range, S As String
Set R = Range(Cells(1, "I"), Cells(Rows.Count, "I").End(xlUp)) ' CHANGE COLUMN CODE
 
Columns(10).EntireColumn.Insert     ' CHANGE COLUMN CODE
For Each cell In R
 If cell.Font.ColorIndex = 3 Then
   cell.Copy cell.Offset(0, 1)
   cell.ClearContents
 End If
Next
Columns("J:J").Select     ' CHANGE COLUMN CODE
    Selection.Font.ColorIndex = 1
 
End Sub
Sub MoveRedJ()
Application.ScreenUpdating = False
Cells.Select
    Selection.Sort Key1:=Range("J2"), Order1:=xlAscending, Header:=xlYes, _
        OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
        DataOption1:=xlSortNormal
    Range("J1").Select
Call duplicates_In_Red
On Error Resume Next
Columns("J:J").Select     ' CHANGE COLUMN CODE
Dim R As Range, r1 As Range
Dim cell As Range, cell1 As Range, S As String
Set R = Range(Cells(1, "J"), Cells(Rows.Count, "J").End(xlUp)) ' CHANGE COLUMN CODE
 
Columns(11).EntireColumn.Insert     ' CHANGE COLUMN CODE
For Each cell In R
 If cell.Font.ColorIndex = 3 Then
   cell.Copy cell.Offset(0, 1)
   cell.ClearContents
 End If
Next
Columns("K:K").Select     ' CHANGE COLUMN CODE
    Selection.Font.ColorIndex = 1
 
End Sub
Sub MoveRedK()
Application.ScreenUpdating = False
Cells.Select
    Selection.Sort Key1:=Range("K2"), Order1:=xlAscending, Header:=xlYes, _
        OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
        DataOption1:=xlSortNormal
    Range("K1").Select
Call duplicates_In_Red
On Error Resume Next
Columns("K:K").Select     ' CHANGE COLUMN CODE
Dim R As Range, r1 As Range
Dim cell As Range, cell1 As Range, S As String
Set R = Range(Cells(1, "K"), Cells(Rows.Count, "K").End(xlUp)) ' CHANGE COLUMN CODE
 
Columns(12).EntireColumn.Insert     ' CHANGE COLUMN CODE
For Each cell In R
 If cell.Font.ColorIndex = 3 Then
   cell.Copy cell.Offset(0, 1)
   cell.ClearContents
 End If
Next
Columns("L:L").Select     ' CHANGE COLUMN CODE
    Selection.Font.ColorIndex = 1
 
End Sub
Sub MoveRedL()
Application.ScreenUpdating = False
Cells.Select
    Selection.Sort Key1:=Range("L2"), Order1:=xlAscending, Header:=xlYes, _
        OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
        DataOption1:=xlSortNormal
    Range("L1").Select
Call duplicates_In_Red
On Error Resume Next
Columns("L:L").Select     ' CHANGE COLUMN CODE
Dim R As Range, r1 As Range
Dim cell As Range, cell1 As Range, S As String
Set R = Range(Cells(1, "L"), Cells(Rows.Count, "L").End(xlUp)) ' CHANGE COLUMN CODE
 
Columns(13).EntireColumn.Insert     ' CHANGE COLUMN CODE
For Each cell In R
 If cell.Font.ColorIndex = 3 Then
   cell.Copy cell.Offset(0, 1)
   cell.ClearContents
 End If
Next
Columns("M:M").Select     ' CHANGE COLUMN CODE
    Selection.Font.ColorIndex = 1
 
End Sub
Sub MoveRedM()
Application.ScreenUpdating = False
Cells.Select
    Selection.Sort Key1:=Range("M2"), Order1:=xlAscending, Header:=xlYes, _
        OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
        DataOption1:=xlSortNormal
    Range("M1").Select
Call duplicates_In_Red
On Error Resume Next
Columns("M:M").Select     ' CHANGE COLUMN CODE
Dim R As Range, r1 As Range
Dim cell As Range, cell1 As Range, S As String
Set R = Range(Cells(1, "M"), Cells(Rows.Count, "M").End(xlUp)) ' CHANGE COLUMN CODE
 
Columns(14).EntireColumn.Insert     ' CHANGE COLUMN CODE
For Each cell In R
 If cell.Font.ColorIndex = 3 Then
   cell.Copy cell.Offset(0, 1)
   cell.ClearContents
 End If
Next
Columns("N:N").Select     ' CHANGE COLUMN CODE
    Selection.Font.ColorIndex = 1
 
End Sub
Sub MoveRedN()
Application.ScreenUpdating = False
Cells.Select
    Selection.Sort Key1:=Range("N2"), Order1:=xlAscending, Header:=xlYes, _
        OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
        DataOption1:=xlSortNormal
    Range("N1").Select
Call duplicates_In_Red
On Error Resume Next
Columns("N:N").Select     ' CHANGE COLUMN CODE
Dim R As Range, r1 As Range
Dim cell As Range, cell1 As Range, S As String
Set R = Range(Cells(1, "N"), Cells(Rows.Count, "N").End(xlUp)) ' CHANGE COLUMN CODE
 
Columns(15).EntireColumn.Insert     ' CHANGE COLUMN CODE
For Each cell In R
 If cell.Font.ColorIndex = 3 Then
   cell.Copy cell.Offset(0, 1)
   cell.ClearContents
 End If
Next
Columns("O:O").Select     ' CHANGE COLUMN CODE
    Selection.Font.ColorIndex = 1
  Application.ScreenUpdating = True
End Sub
 
Sub COLUMN_RANGE()
Dim R As Range, r1 As Range
Set R = Selection(1)
Set r1 = Cells(Rows.Count, R.Column).End(xlUp)
If r1.Row >= R.Row Then
Range(R, r1).Select
On Error GoTo 0
End If
End Sub
 
Sub duplicates_In_Red()
Call COLUMN_RANGE
Application.ScreenUpdating = False
'
' SELECT RANGE FIRST
'try adding and removing the (End If) as will only work if you have an if statement inserted
'
Rng = Selection.Rows.Count
For I = Rng To 1 Step -1
myCheck = ActiveCell
ActiveCell.Offset(1, 0).Select
For j = 1 To I
If ActiveCell = myCheck Then
Selection.Font.Bold = False
Selection.Font.ColorIndex = 3
End If
ActiveCell.Offset(1, 0).Select
Next j
ActiveCell.Offset(-I, 0).Select
Next I
End Sub

paste the following dummy data into sheet 1, just so that you can see what will happen.

<TABLE style="WIDTH: 216pt; BORDER-COLLAPSE: collapse" border=0 cellSpacing=0 cellPadding=0 width=288><COLGROUP><COL style="WIDTH: 72pt" span=3 width=96><TBODY><TR style="HEIGHT: 18pt" height=24><TD style="BORDER-BOTTOM: windowtext 0.5pt solid; BORDER-LEFT: windowtext 0.5pt solid; BACKGROUND-COLOR: transparent; WIDTH: 72pt; HEIGHT: 18pt; BORDER-TOP: windowtext 0.5pt solid; BORDER-RIGHT: windowtext 0.5pt solid" class=xl63 height=24 width=96>columnA</TD><TD style="BORDER-BOTTOM: windowtext 0.5pt solid; BORDER-LEFT: windowtext; BACKGROUND-COLOR: transparent; WIDTH: 72pt; BORDER-TOP: windowtext 0.5pt solid; BORDER-RIGHT: windowtext 0.5pt solid" class=xl63 width=96>columnB</TD><TD style="BORDER-BOTTOM: windowtext 0.5pt solid; BORDER-LEFT: windowtext; BACKGROUND-COLOR: transparent; WIDTH: 72pt; BORDER-TOP: windowtext 0.5pt solid; BORDER-RIGHT: windowtext 0.5pt solid" class=xl63 width=96>columnC</TD></TR><TR style="HEIGHT: 18pt" height=24><TD style="BORDER-BOTTOM: windowtext 0.5pt solid; BORDER-LEFT: windowtext 0.5pt solid; BACKGROUND-COLOR: transparent; HEIGHT: 18pt; BORDER-TOP: windowtext; BORDER-RIGHT: windowtext 0.5pt solid" class=xl63 height=24 align=right>1111</TD><TD style="BORDER-BOTTOM: windowtext 0.5pt solid; BORDER-LEFT: windowtext; BACKGROUND-COLOR: transparent; BORDER-TOP: windowtext; BORDER-RIGHT: windowtext 0.5pt solid" class=xl63></TD><TD style="BORDER-BOTTOM: windowtext 0.5pt solid; BORDER-LEFT: windowtext; BACKGROUND-COLOR: transparent; BORDER-TOP: windowtext; BORDER-RIGHT: windowtext 0.5pt solid" class=xl63>apple</TD></TR><TR style="HEIGHT: 18pt" height=24><TD style="BORDER-BOTTOM: windowtext 0.5pt solid; BORDER-LEFT: windowtext 0.5pt solid; BACKGROUND-COLOR: transparent; HEIGHT: 18pt; BORDER-TOP: windowtext; BORDER-RIGHT: windowtext 0.5pt solid" class=xl63 height=24 align=right>1111</TD><TD style="BORDER-BOTTOM: windowtext 0.5pt solid; BORDER-LEFT: windowtext; BACKGROUND-COLOR: transparent; BORDER-TOP: windowtext; BORDER-RIGHT: windowtext 0.5pt solid" class=xl63></TD><TD style="BORDER-BOTTOM: windowtext 0.5pt solid; BORDER-LEFT: windowtext; BACKGROUND-COLOR: transparent; BORDER-TOP: windowtext; BORDER-RIGHT: windowtext 0.5pt solid" class=xl63>apple</TD></TR><TR style="HEIGHT: 18pt" height=24><TD style="BORDER-BOTTOM: windowtext 0.5pt solid; BORDER-LEFT: windowtext 0.5pt solid; BACKGROUND-COLOR: transparent; HEIGHT: 18pt; BORDER-TOP: windowtext; BORDER-RIGHT: windowtext 0.5pt solid" class=xl63 height=24 align=right>1111</TD><TD style="BORDER-BOTTOM: windowtext 0.5pt solid; BORDER-LEFT: windowtext; BACKGROUND-COLOR: transparent; BORDER-TOP: windowtext; BORDER-RIGHT: windowtext 0.5pt solid" class=xl63></TD><TD style="BORDER-BOTTOM: windowtext 0.5pt solid; BORDER-LEFT: windowtext; BACKGROUND-COLOR: transparent; BORDER-TOP: windowtext; BORDER-RIGHT: windowtext 0.5pt solid" class=xl63>apple</TD></TR><TR style="HEIGHT: 18pt" height=24><TD style="BORDER-BOTTOM: windowtext 0.5pt solid; BORDER-LEFT: windowtext 0.5pt solid; BACKGROUND-COLOR: transparent; HEIGHT: 18pt; BORDER-TOP: windowtext; BORDER-RIGHT: windowtext 0.5pt solid" class=xl63 height=24 align=right>222</TD><TD style="BORDER-BOTTOM: windowtext 0.5pt solid; BORDER-LEFT: windowtext; BACKGROUND-COLOR: transparent; BORDER-TOP: windowtext; BORDER-RIGHT: windowtext 0.5pt solid" class=xl63></TD><TD style="BORDER-BOTTOM: windowtext 0.5pt solid; BORDER-LEFT: windowtext; BACKGROUND-COLOR: transparent; BORDER-TOP: windowtext; BORDER-RIGHT: windowtext 0.5pt solid" class=xl63>pear</TD></TR><TR style="HEIGHT: 18pt" height=24><TD style="BORDER-BOTTOM: windowtext 0.5pt solid; BORDER-LEFT: windowtext 0.5pt solid; BACKGROUND-COLOR: transparent; HEIGHT: 18pt; BORDER-TOP: windowtext; BORDER-RIGHT: windowtext 0.5pt solid" class=xl63 height=24 align=right>222</TD><TD style="BORDER-BOTTOM: windowtext 0.5pt solid; BORDER-LEFT: windowtext; BACKGROUND-COLOR: transparent; BORDER-TOP: windowtext; BORDER-RIGHT: windowtext 0.5pt solid" class=xl63></TD><TD style="BORDER-BOTTOM: windowtext 0.5pt solid; BORDER-LEFT: windowtext; BACKGROUND-COLOR: transparent; BORDER-TOP: windowtext; BORDER-RIGHT: windowtext 0.5pt solid" class=xl63>pear</TD></TR></TBODY></TABLE>
 
Upvote 0
Maybe

Excel 2007 or higher
Array-formula in G2
=IFERROR(IF(COUNTIF($B$2:$B2,$B2)=1,INDEX($F$2:$F$11,SMALL(IF($B$2:$B$11=$B2,ROW($B$2:$B$11)-ROW($B$2)+1),COLUMNS($G2:H2))),""),"")

confirmed with Ctrl+Shift+Enter

copy across till I2 and down


Earlier versions
Array-formula in G2
=LOOKUP(REPT("z",255),CHOOSE({1,2},"",IF(COUNTIF($B$2:$B2,$B2)=1,INDEX($F$2:$F$11,SMALL(IF($B$2:$B$11=$B2,ROW($B$2:$B$11)-ROW($B$2)+1),COLUMNS($G2:H2))),"")))

confirmed with Ctrl+Shift+Enter

copy across till I2 and down

HTH

M.
 
Upvote 0
Thank you Jaye for the code. Marcelo, I think you formula will do the trick, how can I modiy the code to work on variable length columns?
 
Upvote 0
trimmer69 said:
Thank you Jaye for the code. Marcelo, I think you formula will do the trick, how can I modiy the code to work on variable length columns?
Click to expand...

Could uou elaborate more about work on variable lenght columns? maybe simply extending the ranges in my formula(s)

By the way, what Excel version are you using?

M.
 
Last edited:
Upvote 0
I use 2003 at work and 2007 at home. I would like to add that formula to a macro that will will be used by multiple users, which all have different experience levels with Excel. The current data set that I am working on today is 300 rows, in the future I could have 20,000 rows.
 
Upvote 0
trimmer69 said:
I use 2003 at work and 2007 at home. I would like to add that formula to a macro that will will be used by multiple users, which all have different experience levels with Excel. The current data set that I am working on today is 300 rows, in the future I could have 20,000 rows.
Click to expand...


With 20,000 rows maybe a macro is better

Try this

Code: 
Sub arrData()
    Dim firstRow As Long, lastRow As Long
    Dim i As Long, lin As Long, offsetCol As Long
    Dim wk As Worksheet
    
    Application.ScreenUpdating = False
    
    Set wk = Sheets("Sheet1") '<--Adjust the sheetname
    
    With wk
        'Assumes data begin in row 2. Adjust to suit
        firstRow = 2
        'Get the last row with data in Column B. Adjust to suit
        lastRow = .Cells(.Rows.Count, "B").End(xlUp).Row
        
        lin = firstRow
        offsetCol = 5
        
        For i = firstRow To lastRow
            If Application.CountIf(Range("B2:B" & i), .Cells(i, 2)) > 1 Then
                Range("B" & lin).Offset(0, offsetCol) = .Cells(i, 6)
                offsetCol = offsetCol + 1
            Else
                lin = i
                offsetCol = 5
            End If
            
        Next i
    End With
    
    Application.ScreenUpdating = True
    
End Sub

HTH

M.
 
Last edited:
Upvote 0
You must log in or register to reply here.

Similar threads

D
  • Question Question
Locate first instance of all dates in a column and hide all remaining rows
Replies
4
Views
111
Peter_SSs
Peter_SSs
G
  • Question Question
Format Pulled Data from Workbook into a Text Box
Replies
6
Views
123
Fuji
F
V
  • Question Question
Filter or any other function for filter the data
Replies
8
Views
180
Fuji
F
F
  • Question Question
Changing date format based on fiscal years versus calendar years
Replies
2
Views
196
Peter_SSs
Peter_SSs
G
  • Solved
If Else Loop macro running slow, anyway to speed it up?
Replies
9
Views
299
Alex Blakenburg
A

Forum statistics

Threads
1,224,521
Messages
6,179,285
Members
452,902
Latest member
Knuddeluff

Share this page

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top