Paste information in different sheets (would like to specify started at cell A1 in each sheet)

Question

There are 3 groups (A,B,C) of data in excel sheet1, and in my workbook i already create 3 sheets named (A, B, C).

I have no problem to copy group A,B,C data into their corresponding sheet, e.g. copy group A data into sheet A, however i find in some cases the selected cell at the beginning of each sheet is not in A1, e.g. the selected cell at the beginning maybe at somewhere other cells in excel (e.g. B10), this make the presentation looks messy, i want the all the data in each sheet start at A1. I know some of you may said using the code Range("a1").selected can manage this situation, however we need to use the "Do loop" to loop over each row in sheet1 to identify that row is belong to A,B or C, then we paste that row into the corresponding sheet. I found if i include the code Range("a1").selected, then each time the program will paste the row in Sheet1 into the cell A1 in sheet A,B and C, and at the end there will only one row appear in each sheets. What should i improve the program below so that each time the data in each group can be appeared at the beginning of cell A1 in their worksheet even sometimes the selected cell of each sheet is not in cell A1? Thanks.

Sub data_category()
    Dim y As Integer
    Dim x As String
    
    Sheets("sheet1").Activate
    Range("a3").Select
    
    Do Until ActiveCell.Value = ""
        
        y = ActiveCell.Offset(0, 3).Value
        
        If y < 90 Then
            x = "A"
        ElseIf y < 120 Then
            x = "B"
        Else
            x = "C"
        End If
            
        ActiveCell.Offset(0, 4).Value = x
        Range(ActiveCell, ActiveCell.End(xlToRight)).Copy
        
        Sheets(x).Activate
        Range("a1").Select
        
        ActiveCell.PasteSpecial
        ActiveCell.Offset(1, 0).Select
        
        Sheets("sheet1").Activate
        ActiveCell.Offset(1, 0).Select
        
    Loop
End Sub

Answer 1

Following from Sid's comment:

Sub data_category()
    Dim y As Long
    Dim x As String, c As Range, ws As Worksheet, wb As Workbook, cDest As Range
    
    Set wb = ActiveWorkbook 'or ThisWorkbook: always good to be specific here
    Set c = wb.Worksheets("sheet1").Range("a3") 'get a reference to the starting cell
    Do Until Len(c.Value) = 0
        
        y = c.Offset(0, 3).Value
        Select Case y               'tidier then if...else if
            Case Is < 90: x = "A"
            Case Is < 120: x = "B"
            Case Else: x = "C"
        End Select
        
        c.Offset(0, 4).Value = x

        'direct copy to next empty row with no select/activate
        Set cDest = wb.Worksheets(x).Cells(Rows.Count, 1).End(xlUp)
        If Len(cDest).Value > 0 Then Set cDest = cDest.Offset(1, 0)
        c.EntireRow.Copy cDest
    
        Set c = c.Offset(1,0) '<<<<<<<<<<<<< edit - added
    Loop
    c.Parent.Activate
End Sub

Answer 2

Rather than the Do-Loop approach, I would do this slightly different for a faster execution.

Logic

1. Find last row in Sheet1 of Col A
2. Insert formula =IF(D3<90,"A",IF(D3<120,"B","C")) in Col E starting at row 3
3. Next I will use autofilter to filter column E on A first and copy all data in one go to Sheet A. I will repeat the process for B and C

My Assumptions

1. Row 2 has headers. If not, tweak the code accordingly.

Code

I have commented the code so you will not have a problem understanding it, but if you do, then simply ask.

Option Explicit

Dim ws As Worksheet
Dim rng As Range

Sub Sample()
    Set ws = ThisWorkbook.Sheets("Sheet1")
    
    Dim lRow As Long
    
    With ws
        '~~> Remove any filters
        .AutoFilterMode = False
        
        '~~> Find last row
        lRow = .Range("A" & .Rows.Count).End(xlUp).Row
        
        '~~> Insert formula in Col E
        With .Range("E3:E" & lRow)
            .Formula = "=IF(D3<90,""A"",IF(D3<120,""B"",""C""))"
            .Value = .Value
        End With
        
        '~~> Identify the range to work with
        Set rng = .Range("A2:E" & lRow)
        
        '~~> Copy rows with relevant criteria
        CopyData "A"
        CopyData "B"
        CopyData "C"
        
        .AutoFilterMode = False
    End With
End Sub

Private Sub CopyData(shName As String)
    Dim rngToCopy As Range
    
    '~~> Filter column E on the search string
    With rng
        .AutoFilter Field:=5, Criteria1:=shName
        Set rngToCopy = .Offset(1, 0).SpecialCells(xlCellTypeVisible).EntireRow
    End With
    
    '~~> Copy all data in one go
    If Not rngToCopy Is Nothing Then rngToCopy.Copy ThisWorkbook.Sheets(shName).Rows(1)
    
    ws.AutoFilterMode = False
End Sub

In Action

Answer 3

Update Category Reports

Option Explicit

Sub UpdateCategoryReports()
    
    Const sfRow As Long = 3 ' First Row (headers are in row 'sfRow - 1')
    Const sfCol As Long = 1
    
    Const dfRow As Long = 2 ' First Row (headers are in row 'dfRow - 1')
    
    Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
    
    Dim sws As Worksheet: Set sws = wb.Worksheets("Sheet1")
    
    Dim slRow As Long: slRow = sws.Cells(sws.Rows.Count, "A").End(xlUp).Row
    If slRow < sfRow Then Exit Sub ' no data (highly unlikely)
    
    Dim slCol As Long
    slCol = sws.Cells(sfRow - 1, sws.Columns.Count).End(xlToLeft).Column
    
    Application.ScreenUpdating = False
    
    Dim dws As Worksheet ' Destination Worksheet
    Dim durg As Range ' Destination 'UsedRange'
    Dim dcrg As Range ' Destination Clear Range
    
    ' Clear destination data.
    For Each dws In wb.Worksheets(Array("A", "B", "C"))
        Set durg = dws.UsedRange  ' Destination Used Range
        If durg.Rows.Count > 1 Then
            ' You don't want to clear the headers:
            ' e.g. if 'durg' is 'A1:J10' then 'dcrg' will be 'A2:J10'.
            Set dcrg = durg.Resize(durg.Rows.Count - 1).Offset(1)
            dcrg.Clear
        End If
    Next dws
    
    Dim srrg As Range ' Source Row Range
    Dim sRow As Long ' Source Row
    
    Dim dfCell As Range ' Destination First Cell (Range)
    Dim dRow As Long ' Destination (Available) Row
    Dim sValue As Double ' Source Value
    Dim dwsName As String ' Destination Worksheet Name
    
    For sRow = sfRow To slRow
        
        If IsNumeric(sws.Cells(sRow, "D").Value) Then
            
            sValue = sws.Cells(sRow, "D").Value
            
            If sValue < 90 Then
                dwsName = "A"
            ElseIf sValue < 120 Then
                dwsName = "B"
            Else
                dwsName = "C"
            End If
            
            Set srrg = sws.Range(sws.Cells(sRow, "A"), sws.Cells(sRow, slCol))
            sws.Cells(sRow, "E").Value = dwsName ' ?
            
            Set dws = wb.Worksheets(dwsName)
            dRow = dws.Cells(dws.Rows.Count, "A").End(xlUp).Row + 1
            Set dfCell = dws.Cells(dRow, "A")
            
            ' This will copy values, formats, and formulas. You may need another
            ' way. If there are formulas in source and you only need values,
            ' copying by assignment is the most efficient way. If you also need
            ' the formats you will have to use the least efficient PasteSpecial.
            srrg.Copy Destination:=dfCell
        
        'Else ' sValue is not numeric: do nothing
        End If
        
    Next sRow
 
    'sws.Activate
    'sws.Cells(1).Activate

    Application.ScreenUpdating = True
    
    MsgBox "Category reports updated.", vbInformation, "Category Reports"

End Sub