Cutting rows based on Column G Macro

H

hassimir

New Member
Joined
Feb 23, 2010
Messages
10
Hey Guys I've been having some problem figuring this one out.

I have an excel file with quite a bit of data and I need to be able to cut rows from sheet 1 into sheet 2 based on wether or not column G is blank. (if it is blank I need it moved).

Any ideas how VBA handles blank cells? That seems to be the stumbling block for me. Any code that I can try out would be appreciated.

Thanks!
Mike
 

Excel Facts

Excel motto
Not everything I do at work revolves around Excel. Only the fun parts.
Sort by date Sort by votes
Try

Code: 
Sub test()
Dim LR As Long, i As Long
Application.ScreenUpdating = False
With Sheets("Sheet1")
    LR = .Range("A" & Rows.Count).End(xlUp).Row
    For i = 1 To LR
        With .Range("G" & i)
            If .Value = "" Then .EntireRow.Cut Destination:=Sheets("Sheet2").Range("A" & Rows.Count).End(xlUp).Offset(1)
        End With
    Next i
    On Error Resume Next
    .Columns("A").SpecialCells(xlCellTypeBlanks).EntireRow.Delete
    On Error GoTo 0
End With
Application.ScreenUpdating = True
End Sub
 
Upvote 0
For whatever reason this one didnt work either? Even with a fresh macro on a test sheet I couldn't get it to work. Im trying to integrate this into another larger macro to get most of the manual work done all at once.

Code: 
Public Sub Masterlist()
Dim LR As Long, i As Long
Range("A:A, C:F, I:L, O:T, W:Y, AA:AD").Delete
 Application.ScreenUpdating = False
 
 With ActiveSheet
  .AutoFilterMode = False
    With Range("H1", Range("H" & Rows.Count).End(xlUp))
        .AutoFilter 1, "Y"
        On Error Resume Next
        .Offset(1).SpecialCells(12).EntireRow.Delete
    End With
    .AutoFilterMode = False
    End With
    
    With Sheets("Sheet1")
    LR = .Range("A" & Rows.Count).End(xlUp).Row
    For i = 1 To LR
        With .Range("G" & i)
            If .Value = "" Then .EntireRow.Cut Destination:=Sheets("Sheet2").Range("A" & Rows.Count).End(xlUp).Offset(1)
        End With
    Next i
    On Error Resume Next
    .Columns("A").SpecialCells(xlCellTypeBlanks).EntireRow.Delete
    On Error GoTo 0
End With
Columns("C:C").Select
    Selection.Copy
    Columns("O:O").Select
    ActiveSheet.Paste
    Application.CutCopyMode = False
    Selection.TextToColumns Destination:=Range("O1"), DataType:=xlDelimited, _
        TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=False, _
        Semicolon:=False, Comma:=False, Space:=False, Other:=True, OtherChar _
        :=":", FieldInfo:=Array(Array(1, 1), Array(2, 1)), TrailingMinusNumbers:=True
    Columns("P:P").Select
    Selection.Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
    Columns("O:O").Select
    Selection.TextToColumns Destination:=Range("O1"), DataType:=xlDelimited, _
        TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=True, Tab:=False, _
        Semicolon:=False, Comma:=False, Space:=True, Other:=False, OtherChar _
        :=":", FieldInfo:=Array(Array(1, 1), Array(2, 1)), TrailingMinusNumbers:=True
        
        Cells.Select
    ActiveWorkbook.Worksheets("Sheet1").Sort.SortFields.Clear
    ActiveWorkbook.Worksheets("Sheet1").Sort.SortFields.Add Key:=Range( _
        "O2:O14926"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:= _
        xlSortNormal
    With ActiveWorkbook.Worksheets("Sheet1").Sort
        .SetRange Range("A1:AE14926")
        .Header = xlYes
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
    
Set rng = Range("O2:O" & Cells _
(Rows.Count, 1).End(xlUp).Row)
'Set rng = ActiveSheet.UsedRange
For Each cell In rng
       s = cell.Text
     Select Case s
      Case "Not"
       cell.Value = "X"
      Case "FND"
       cell.Value = "X"
      Case "Other"
       cell.Value = "X"
       Case "CAN"
       cell.Value = "X"
       Case "DLR"
       cell.Value = "X"
       Case "ABF"
       cell.Value = "X"
       Case "CCF"
       cell.Value = "X"
       Case "RAU"
       cell.Value = "X"
       Case "MVR"
       cell.Value = "X"
       
Columns("P:P").Delete
With ActiveSheet
  .AutoFilterMode = False
    With Range("P1", Range("P" & Rows.Count).End(xlUp))
        .AutoFilter 1, "Cancel Automatic Payment Plan for 'A' deal Acct. due to MELLON BANK rejected on  C03 Unable to locate account. MELLONachr100303"
        On Error Resume Next
        .Offset(1).SpecialCells(12).EntireRow.Delete
    End With
    .AutoFilterMode = False
    End With
    
    With ActiveSheet
  .AutoFilterMode = False
    With Range("P1", Range("P" & Rows.Count).End(xlUp))
        .AutoFilter 1, "Beacon Score Not Fundable or Rule Not Found"
        On Error Resume Next
        .Offset(1).SpecialCells(12).EntireRow.Delete
    End With
    .AutoFilterMode = False
    End With
With ActiveSheet
  .AutoFilterMode = False
    With Range("P1", Range("P" & Rows.Count).End(xlUp))
        .AutoFilter 1, "CANCELLED Requests"
        On Error Resume Next
        .Offset(1).SpecialCells(12).EntireRow.Delete
    End With
    .AutoFilterMode = False
    End With
      
With ActiveSheet
  .AutoFilterMode = False
    With Range("P1", Range("P" & Rows.Count).End(xlUp))
        .AutoFilter 1, "Contract Approved but Has Other Paperwork Issues"
        On Error Resume Next
        .Offset(1).SpecialCells(12).EntireRow.Delete
    End With
    .AutoFilterMode = False
    End With
       
      With ActiveSheet
  .AutoFilterMode = False
    With Range("P1", Range("P" & Rows.Count).End(xlUp))
        .AutoFilter 1, "Contract Completed - Not Fundable"
        On Error Resume Next
        .Offset(1).SpecialCells(12).EntireRow.Delete
    End With
    .AutoFilterMode = False
    End With
     
    With ActiveSheet
  .AutoFilterMode = False
    With Range("P1", Range("P" & Rows.Count).End(xlUp))
        .AutoFilter 1, "Contract is Cancelled"
        On Error Resume Next
        .Offset(1).SpecialCells(12).EntireRow.Delete
    End With
    .AutoFilterMode = False
    End With
      
  With ActiveSheet
  .AutoFilterMode = False
    With Range("P1", Range("P" & Rows.Count).End(xlUp))
        .AutoFilter 1, "Failed Paperwork"
        On Error Resume Next
        .Offset(1).SpecialCells(12).EntireRow.Delete
    End With
    .AutoFilterMode = False
    End With
    
    
  With ActiveSheet
  .AutoFilterMode = False
    With Range("P1", Range("P" & Rows.Count).End(xlUp))
        .AutoFilter 1, "Failed paperwork or QA"
        On Error Resume Next
        .Offset(1).SpecialCells(12).EntireRow.Delete
    End With
    .AutoFilterMode = False
    End With
      
    With ActiveSheet
  .AutoFilterMode = False
    With Range("P1", Range("P" & Rows.Count).End(xlUp))
        .AutoFilter 1, "Paperwork Approved but Failed QA"
        On Error Resume Next
        .Offset(1).SpecialCells(12).EntireRow.Delete
    End With
    .AutoFilterMode = False
    End With
 
     With ActiveSheet
  .AutoFilterMode = False
    With Range("P1", Range("P" & Rows.Count).End(xlUp))
        .AutoFilter 1, "Paperwork Approved but No Contact (13 days not elapsed since cut-in)"
        On Error Resume Next
        .Offset(1).SpecialCells(12).EntireRow.Delete
    End With
    .AutoFilterMode = False
    End With
    
    
     With ActiveSheet
  .AutoFilterMode = False
    With Range("P1", Range("P" & Rows.Count).End(xlUp))
        .AutoFilter 1, "Paperwork Approved but QA in Process"
        On Error Resume Next
        .Offset(1).SpecialCells(12).EntireRow.Delete
    End With
    .AutoFilterMode = False
    End With
    
     With ActiveSheet
  .AutoFilterMode = False
    With Range("P1", Range("P" & Rows.Count).End(xlUp))
        .AutoFilter 1, "Paperwork Approved but QA in Process"
        On Error Resume Next
        .Offset(1).SpecialCells(12).EntireRow.Delete
    End With
    .AutoFilterMode = False
    End With
 
 
      
      End Select
   Next cell
   On Error Resume Next
 
End Sub

Do you see an error that would have caused it to fail in this? I'm also open to critiquing, this is my first major macro longer than a few lines.
 
Upvote 0
What is actually in column G? What does

=CODE(G1)

return where G1 is a 'blank' cell.
 
Upvote 0
Then the value is blank.

I cannot understand why the code does not work for you
 
Upvote 0
I guess Ill just have to work with what I've got and try to simplify the code. I know its messy so maybe I just have some stray variables.
 
Upvote 0
You must log in or register to reply here.

Similar threads

S
  • Question Question
Big, Multi-Step Macro for Efficiently Cutting Big Pieces Into Small Pieces
Replies
1
Views
484
Solon Aquila
S
M
  • Solved
cut/copy and paste row based on cell value not being equal to specific text
Replies
6
Views
480
mlan1604
M
E
  • Question Question
VLOOKUP or similar to cut/paste data
Replies
3
Views
408
kvsrinivasamurthy
K
B
  • Question Question
VBA code to cut and paste multiple filtered rows based on multiple criteria
Replies
2
Views
1K
Alex Blakenburg
A
A
  • Question Question
Macro to move certain columns to new sheet based on status (ie; "done")
2
Replies
10
Views
736
AnnyCav
A

Forum statistics

Threads
1,223,767
Messages
6,174,390
Members
452,561
Latest member
amir5104

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