Delete rows, then reorganise remaining data

**Steve_123** · 01-10-2014, 02:52 AM

Hi there

I'm hoping someone can help me delete some rows from a worksheet, then reorganise a lot more.

I've got an exceptionally slow way of doing it at the moment with millions of lines of very bad code from just recording various steps but it crashes my computer every time so I'm hoping there's a quicker way.

I've attached a sample document for what the information looks like now and what I'd like it to look like afterwards.

I've used two sheets for clarity but ideally would like the action to happen over the top on the one sheet. This is not essential though.

There are three members in the sample but in reality there could be 100s - it will vary each time. The data in A will always follow the same pattern, but in B there may be the odd field that is missing information.

I'm hoping to have the information in A18:B20 deleted, to follow in this way for each member, so deleting the rows relating to the below, then reorganising the remaining info as per the After sheet.

Type
Last Viewed
Last notified

Thanks as ever for your help.

Steve

**JBeaucaire** · 01-10-2014, 03:15 AM

With consistently laid out data, VBA isn't really needed. Drop the new data into NOW, then these formulas on AFTER will reorganize it:

A2: =INDEX(Now!A:A,ROWS($A$1:$A1)*21-20) (copied down until blanks appear)

B2: =IF($A2="", "", INDEX(Now!$B:$B, MATCH($A2, Now!$A:$A, 0)+COLUMNS($A$1:A$1))&"") (copied down and across the remaining table).

Once all the values are showing, you can highlight the data, then COPY > PASTE SPECIAL > VALUES onto a 3rd sheet to save it permanently with no formulas, leave your other two sheets setup to keep giving you results when you drop new data onto the first sheet.

**:) Sixthsense :)** · 01-10-2014, 04:03 AM

How to install your new code

Copy the Excel VBA code
Select the workbook in which you want to store the Excel VBA code
Press Alt+F11 to open the Visual Basic Editor
Choose Insert > Module
Edit > Paste the macro into the module that appeared
Close the VBEditor
Save your workbook (Excel 2007+ select a macro-enabled file format, like *.xlsm)

To run the Excel VBA code:

Press Alt-F8 to open the macro list
Select a macro in the list
Click the Run button

Sub OrganiseData()
Dim wResult As Worksheet, wBase As Worksheet, lRw As Long, blHeader As Boolean

Set wBase = ActiveSheet
Set wResult = Sheets.Add

wBase.Select
lRw = wResult.Cells(Rows.Count, "A").End(xlUp).Row

Application.ScreenUpdating = False

Do
  With Range("A1")
        Select Case UCase(.Value)
            Case Is = "TYPE": .CurrentRegion.EntireRow.Delete
            Case Is = "": .EntireRow.Delete
            Case Else
                If blHeader = False Then
                    .CurrentRegion.Resize(.CurrentRegion.Rows.Count - 1).Offset(1).Columns(1).Copy
                    wResult.Cells(lRw, "A").PasteSpecial xlPasteValues, , , True
                    blHeader = True
                End If
                lRw = wResult.Cells(Rows.Count, "A").End(xlUp).Row + 1
                wResult.Range("A" & lRw).Value = .Value
                .CurrentRegion.Resize(.CurrentRegion.Rows.Count - 1).Offset(1).Columns(2).Copy
                wResult.Cells(lRw, "B").PasteSpecial xlPasteValues, , , True
                .CurrentRegion.EntireRow.Delete
        End Select
    End With
    If wBase.UsedRange.Rows.Count = 1 Then Exit Do
Loop

wResult.Range("A1").CurrentRegion.EntireColumn.AutoFit

Application.ScreenUpdating = True

End Sub

**Steve_123** · 01-10-2014, 04:08 AM

You are an amazing man Jerry and have saved me literally hours if not days! For your amusement I'll post the woeful home made code I was using to achieve the same thing. It locked up my laptop every time!

    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    Rows("1:2").Select
    Application.CutCopyMode = False
    Selection.Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
    
    Range("A1").Select
    Selection.Cut
    Range("D1").Select
    ActiveSheet.Paste
    Range("A1").Select
    ActiveCell.FormulaR1C1 = "A"
    Range("B1").Select
    ActiveCell.FormulaR1C1 = "B"
    Range("C1").Select
    ActiveCell.FormulaR1C1 = "C"
    Columns("A:C").Select
    Selection.AutoFilter
    ActiveSheet.Range("$A$1:$C$60301").AutoFilter Field:=1, Criteria1:= _
        "=Last viewed", Operator:=xlOr, Criteria2:="=View full CV"
    Rows("20:20").Select
    Range(Selection, Selection.End(xlDown)).Select
    Selection.Delete Shift:=xlUp
    ActiveSheet.Range("$A$1:$C$50701").AutoFilter Field:=1, Criteria1:= _
        "Last notified by CV watchdog"
    Selection.Delete Shift:=xlUp
    ActiveSheet.Range("$A$1:$C$50401").AutoFilter Field:=1
    Range("C3").Select
    ActiveCell.FormulaR1C1 = _
        "=IF(R[-1]C[-2]="""",RC[-2],IF(RC[-2]="""","""",R[-1]C))"
    Range("C3").Select
    Selection.AutoFill Destination:=Range("C3:C50401")
    Range("C3:C50401").Select
    ActiveSheet.Range("$A$1:$C$50401").AutoFilter Field:=1, Criteria1:="="
    Range("A19").Select
    ActiveCell.FormulaR1C1 = "=IF(R[-1]C<>""Skill Type"",""Skill Type"","""")"
    Range("A19").Select
    Selection.Copy
    Range("A20:A50384").Select
    ActiveSheet.Paste
    Range("B19").Select
    Application.CutCopyMode = False
    ActiveCell.FormulaR1C1 = "=R1C4"
    Range("B19").Select
    Selection.Copy
    Range(Selection, Selection.End(xlDown)).Select
    Range(Selection, Selection.End(xlUp)).Select
    Range("B19:B50383").Select
    ActiveSheet.Range("$A$1:$C$50401").AutoFilter Field:=1, Criteria1:= _
        "Skill Type"
    Range("B19").Select
    Application.CutCopyMode = False
    Selection.Copy
    Range("B37").Select
    Range(Selection, Selection.End(xlDown)).Select
    Range(Selection, Selection.End(xlUp)).Select
    Range("B37:B50383").Select
    ActiveSheet.Paste
    ActiveSheet.Range("$A$1:$C$50401").AutoFilter Field:=1
    Application.CutCopyMode = False
    Cells.Select
    Selection.Copy
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    Application.CutCopyMode = False
    Range("A4:A8").Select
    Range(Selection, Selection.End(xlDown)).Select
    Range(Selection, Selection.End(xlUp)).Select
    Range("A4:A19").Select
    Selection.Copy
    Range("E1").Select
    Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _
        False, Transpose:=True
    Columns("A:A").Select
    Application.CutCopyMode = False
    Selection.Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
    ActiveCell.FormulaR1C1 = ""
    Range("A3").Select
    ActiveCell.FormulaR1C1 = "=RC[1]&RC[3]"
    Range("A3").Select
    Selection.AutoFill Destination:=Range("A3:A50401")
    Range("A3:A50401").Select
    Range("F3").Select
    ActiveCell.FormulaR1C1 = "=VLOOKUP((R1C&RC2),C1:C4,3,FALSE)"
    Range("F3").Select
    Selection.Copy
    Range("F3:U5987").Select
    ActiveSheet.Paste
    Cells.Select
    Range("F3").Activate
    Application.CutCopyMode = False
    Range("U50988").Select
    Range(Selection, Selection.End(xlUp)).Select
    Range("U50987").Select
    Range(Selection, Selection.End(xlToLeft)).Select
    Range(Selection, Selection.End(xlUp)).Select
    Range("F4").Select
    Selection.Copy
    Range("F3").Select
    ActiveSheet.Paste
    Range("F4").Select
    Application.CutCopyMode = False
    Range("F3").Select
    Range(Selection, Selection.End(xlToRight)).Select
    Range(Selection, Selection.End(xlDown)).Select
    Selection.Copy
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    Range("H6").Select
    Application.CutCopyMode = False
    Rows("2:2").Select
    Selection.Delete Shift:=xlUp
    Selection.AutoFilter
    Range("F2").Select
    Selection.AutoFilter
    ActiveSheet.Range("$A$1:$U$50986").AutoFilter Field:=6, Criteria1:="#N/A"
    Rows("3:3").Select
    Range(Selection, Selection.End(xlDown)).Select
    Selection.Delete Shift:=xlUp
    Range("I307").Select
    ActiveSheet.Range("$A$1:$U$3887").AutoFilter Field:=6
    Columns("A:A").Select
    Selection.Delete Shift:=xlToLeft
    Columns("B:D").Select
    Selection.Delete Shift:=xlToLeft
    Range("A1").Select
    ActiveCell.FormulaR1C1 = "Name"
    ActiveCell.Columns("A:A").EntireColumn.EntireColumn.AutoFit
    Cells.Replace What:="#N/A", Replacement:="", LookAt:=xlPart, SearchOrder _
        :=xlByRows, MatchCase:=False, SearchFormat:=False, ReplaceFormat:=False
        Columns("C:C").Select
    Selection.Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
    Range("B1").Select
    Selection.Cut
    Range("C1").Select
    ActiveSheet.Paste
    Range("C2").Select
    ActiveCell.FormulaR1C1 = "=LEFT(RC[-1],11)"
    Range("C2").Select
    Selection.AutoFill Destination:=Range("C2:C3887")
    Range("C2:C3887").Select
    Columns("C:C").Select
    Selection.Copy
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    Columns("B:B").Select
    Application.CutCopyMode = False
    Selection.Delete Shift:=xlToLeft
    Range("B2").Select

Delete rows, then reorganise remaining data

LinkBack

Thread Tools

Rate This Thread

Display

Hybrid View

Delete rows, then reorganise remaining data

Re: Delete rows, then reorganise remaining data

Re: Delete rows, then reorganise remaining data

Re: Delete rows, then reorganise remaining data

Thread Information

Users Browsing this Thread

Similar Threads

Code will delete first 2 rows but not the remaining 10

Find data and delete remaining rows (For each loop)

Macro to delete sheets and saves remaining file does not properly delete module

Re: Macro to delete sheets and saves remaining file does not properly delete module

Re: Macro to delete sheets and saves remaining file does not properly delete module

Bookmarks

Bookmarks

Posting Permissions