Help sorting data

[monkeykg]

I am trying to create a macro so when i push a button it sort the data based on rising numbers in column B and if it has a 1 in column C copy that row into the next available row in worksheet 2. This is the code I am currently using. The problem is it is sorting everything fine and copying then deleting but every time it copies it is copying row 1 (my headers) with it irregardless of whats in C1.

Sub test()

'Sorts rows based lowest to highest in column B
Range("b2").CurrentRegion.SOrt key1:=Range("b2"), order1:=xlAscending, Header:=xlGuess


'If column C has a 1 in it then copy the row to next avaliable place in sheet 2
Application.ScreenUpdating = False
With Worksheets("Sheet1")
.Range("A:C").AutoFilter field:=3, Criteria1:="1"
.UsedRange.SpecialCells(xlCellTypeVisible).Copy _
Destination:=Worksheets("Sheet2").Range("A" & Rows.Count).End(xlUp).Offset(1, 0)
End With
Worksheets("Sheet1").AutoFilterMode = False
Application.ScreenUpdating = True


'If columnC has a 1 in it delete that row
Dim c As Range
Dim SrchRng

Set SrchRng = ActiveSheet.Range("C1", ActiveSheet.Range("A2000").End(xlUp))
Do
Set c = SrchRng.Find("1", LookIn:=xlValues)
If Not c Is Nothing Then c.EntireRow.Delete
Loop While Not c Is Nothing


End Sub

Thanks

[Bob Phillips]

Try using

Criteria1:=1

[monkeykg]

Try using

Criteria1:=1

Nope same outcome.

[Bob Phillips]

Then can you post the workbook?

[monkeykg]

Here you go.

Organization Macro.xlsm

[Bob Phillips]

I see what you mean now. The reason is that you are copying visible data, and the header row will always be visible. You need to test if there are any data rows.

Sub test()

    'Sorts rows based lowest to highest in column B
    Range("b2").CurrentRegion.Sort key1:=Range("b2"), order1:=xlAscending, Header:=xlGuess
    
    Application.ScreenUpdating = False
    
    'If column C has a 1 in it then copy the row to next avaliable place in sheet 2
    With Worksheets("Sheet1")
    
        .Range("A:C").AutoFilter field:=3, Criteria1:=1
        With .UsedRange.SpecialCells(xlCellTypeVisible)
        
            If .Rows.Count > 1 Then
            
                .Copy Destination:=Worksheets("Sheet2").Range("A" & Rows.Count).End(xlUp).Offset(1, 0)
                
            End If
        End With
    End With
    Worksheets("Sheet1").AutoFilterMode = False
    
    Application.ScreenUpdating = True

'If columnC has a 1 in it delete that row
Dim c As Range
Dim SrchRng

    Set SrchRng = ActiveSheet.Range("C1", ActiveSheet.Range("C2000").End(xlUp))
    Do
    
        Set c = SrchRng.Find("1", LookIn:=xlValues)
        If Not c Is Nothing Then c.EntireRow.Delete
    Loop While Not c Is Nothing
End Sub

[monkeykg]

I don't know if im just missing something blatant but with that code it doesn't copy anything to the next page irregardless

[Bob Phillips]

That should teach me to test all situations

Sub test()
Dim c As Range
Dim SrchRng
Dim rng As Range
Dim aRng As Range
Dim rowCnt As Long
Dim lastrow As Long
     'Sorts rows based lowest to highest in column B
    Range("B2").CurrentRegion.Sort Key1:=Range("B2"), Order1:=xlAscending, Header:=xlGuess
     
    Application.ScreenUpdating = False
     
     'If column C has a 1 in it then copy the row to next avaliable place in sheet 2
    With Worksheets("Sheet1")
    
        lastrow = .Cells(.Rows.Count, "A").End(xlUp).Row
         
        Set rng = .Range("A1").Resize(lastrow, 3)
        rng.AutoFilter field:=3, Criteria1:=1
        Set rng = rng.SpecialCells(xlCellTypeVisible)
        For Each aRng In rng.Areas
        
            rowCnt = rowCnt + aRng.Rows.Count
        Next aRng
            
        rng.AutoFilter
        
        If rowCnt > 1 Then
        
            rng.Copy Destination:=Worksheets("Sheet2").Range("A" & Rows.Count).End(xlUp).Offset(1, 0)
     
            Application.ScreenUpdating = True
             
             'If columnC has a 1 in it delete that row
             
            Set SrchRng = .Range("C1", .Cells(.Rows.Count, "C").End(xlUp))
            Do
                 
                Set c = SrchRng.Find("1", LookIn:=xlValues)
                If Not c Is Nothing Then c.EntireRow.Delete
            Loop While Not c Is Nothing
        End If
    End With
End Sub