Sub test() Worksheets("sheet1").Activate Set cfind = Cells.Find(what:="SL#", after:=Cells(Rows.Count, "A")) add = cfind.Address j = cfind.Row Do 'msgbox j Set cfind = Cells.FindNext(cfind) If cfind.Address = add Then k = Cells(Rows.Count, "A").End(xlUp).Row GoTo line1 End If k = cfind.Row line1: 'msgbox k Range(Cells(j, "A"), Cells(k - 1, "B")).Copy Worksheets("sheet2").Cells(Rows.Count, "A").End(xlUp).Offset(1, 0).PasteSpecial , Transpose:=True If cfind.Address = add Then Exit Do j = k Loop removeheadings End Sub
Sub removeheadings() Worksheets("sheet2").Activate Range("A1").EntireRow.Delete Do Set cfind = Cells.Find(what:="SL#", after:=Range("A1")) 'msgbox cfind.Address If cfind Is Nothing Then Exit Do If cfind.Address = "$A$1" Then Exit Do cfind.EntireRow.Delete Loop Application.CutCopyMode = False Range("A1").Select End Sub
Sub undo() Worksheets("sheet2").Cells.Clear End Sub
DON'T MISS