PDA

View Full Version : Help sorting data



monkeykg
07-23-2014, 02:43 AM
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
07-23-2014, 04:06 AM
Try using

Criteria1:=1

monkeykg
07-23-2014, 04:32 AM
Try using

Criteria1:=1

Nope same outcome.

Bob Phillips
07-23-2014, 05:28 AM
Then can you post the workbook?

monkeykg
07-23-2014, 05:53 AM
Here you go.

12011

Bob Phillips
07-23-2014, 06:27 AM
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
07-23-2014, 06:06 PM
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
07-24-2014, 01:31 AM
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