Help with sorting parts

[Davealot]

Greetings,
I apologize for asking another question to the forum, but I am very appreciative of all of the help I've received thus far. I'm in need of sorting a set of parts out, I've wrote code that is done incorrectly and I can't figure out what's wrong, specifically I am not sure how to have it offset on sheet 2 when a value is posted, I would like for the code to inspect each cell in Column A until it is empty, and if the first 5 numbers are <= 76249 to place on Sheet 2 starting in column A and if it is >= 76250 then to paste them on sheet 2 starting in column G. I've attached spreadsheet as well as Code that I wrote that fails like a champ. Any help would be greatly appreciate, and again thank you.

Sheets.Add After:=ActiveSheet
    Sheets("Sheet1").Select
    Range("A2").Select
Do Until IsEmpty(ActiveCell)
    If Left(ActiveCell, 5) <= "76249" Then
    Range("A2:E2").Select
    Selection.Copy
    Sheets("Sheet2").Select
    ActiveSheet.Paste
    Range("A:E").Select
        Selection.Delete Shift:=xlUp
        Range("A:E").Select
    Else
        ActiveCell.Offset(1, 0).Select
       
        End If
        Loop
       
   
    End Sub

I'f you'll notice I haven't even bothered with the ">=76250" as I can't even get the first part to work. Thank you.

 

[Chihiro]

Can you show how the output in sheet2 should look like?

 

[Davealot]

Can you show how the output in sheet2 should look like?

Of course, Please see attached, Thank you kindly for any and all help!

 

[Marc L]

Hi !

This is limit to a duplicate post !

If you go this way, the execution will last much more
than the way I gave you in your previous post …
​

 

[Chihiro]

This would be how I'd do it.

Sub Test()
Dim origWs As Worksheet, destWs As Worksheet
Dim lRow As Long
Dim cel As Range

Set origWs = ThisWorkbook.Worksheets("Sheet1")
Set destWs = ThisWorkbook.Worksheets("Sheet2")

With origWs
    If .AutoFilterMode = True Then .AutoFilterMode = False
  
    .Cells(1, 6) = "TempCol"
    lRow = .Cells(Rows.Count, 1).End(xlUp).Row
  
    For Each cel In .Range("A2:A" & lRow)
        cel.Offset(0, 5) = Left(cel.Value, 5)
    Next cel
  
    .Cells.CurrentRegion.AutoFilter Field:=6, Criteria1:="<=76249", Operator:=xlFilterValues
    .Range("A1:E" & lRow).SpecialCells(xlCellTypeVisible).Copy destWs.Cells(1, 1)
  
    .Cells.CurrentRegion.AutoFilter Field:=6, Criteria1:=">=76250", Operator:=xlFilterValues
    .Range("A1:E" & lRow).SpecialCells(xlCellTypeVisible).Copy destWs.Cells(1, 7)
  
    .AutoFilterMode = False
  
    .Range("F:F").Delete
End With

End Sub

 

[Davealot]

Hi !

This is limit to a duplicate post !

If you go this way, the execution will last much more
than the way I gave you in your previous post …
​

My apologies, I am not attempting to duplicate posts, and I understand how it could be seen that way, my apologies

 

[Davealot]

This would be how I'd do it.

Sub Test()
Dim origWs As Worksheet, destWs As Worksheet
Dim lRow As Long
Dim cel As Range

Set origWs = ThisWorkbook.Worksheets("Sheet1")
Set destWs = ThisWorkbook.Worksheets("Sheet2")

With origWs
    If .AutoFilterMode = True Then .AutoFilterMode = False
 
    .Cells(1, 6) = "TempCol"
    lRow = .Cells(Rows.Count, 1).End(xlUp).Row
 
    For Each cel In .Range("A2:A" & lRow)
        cel.Offset(0, 5) = Left(cel.Value, 5)
    Next cel
 
    .Cells.CurrentRegion.AutoFilter Field:=6, Criteria1:="<=76249", Operator:=xlFilterValues
    .Range("A1:E" & lRow).SpecialCells(xlCellTypeVisible).Copy destWs.Cells(1, 1)
 
    .Cells.CurrentRegion.AutoFilter Field:=6, Criteria1:=">=76250", Operator:=xlFilterValues
    .Range("A1:E" & lRow).SpecialCells(xlCellTypeVisible).Copy destWs.Cells(1, 7)
 
    .AutoFilterMode = False
 
    .Range("F:F").Delete
End With

End Sub

This works great, thank you so very much!

 

[Marc L]

No problemo !

That was the same way as Chihiro …
​