Moves rows to sheets...

[tmskipper86]

I am trying to move items from the "TR Retail - 2022 - GLTrans" data sheet to various cells. I want to find all the matching rows based on column D "Branch". Then move to corresponding sheet witht the name. I attached images.

 

[portews]

Try this:

Sub move2Shts()
'https://www.mrexcel.com/board/threads/moves-rows-to-sheets.1215896/
Dim CellValue As Range
Dim CUnique As New Collection
Dim VUnique As Variant
Dim ws As Worksheet
Dim LastRow As Long
Dim DestRows As Long

LastRow = Sheets("TR Retail - 2022 - GLTrans").Range("D" & Rows.Count).End(xlUp).Row

'get list of unique value in D. You can't have two items with the same name in a collection,
'so when it errors due to a duplicate name, we just go to the next value
On Error Resume Next

'Adding unique items to collection from defined range
For Each CellValue In Range("D2:D" & LastRow)
    CUnique.Add CellValue.Value, CStr(CellValue.Value)
Next

On Error GoTo 0

With ThisWorkbook.Sheets("TR Retail - 2022 - GLTrans")
    'look at each unique value in D
    For Each VUnique In CUnique
        
        'make sure a worksheet with that name exists.
        On Error Resume Next
        Set ws = ThisWorkbook.Sheets(VUnique)
        On Error GoTo 0
        'if not, make one
        If ws Is Nothing Then
            Worksheets.Add.Name = VUnique
            Set ws = ThisWorkbook.Sheets(VUnique)
        End If
        
        'filter the list by the Branch
        .Range("D1").AutoFilter Field:=1, Criteria1:=VUnique
        'copy only the filtered rows
        .Range("A2:H" & LastRow).SpecialCells(xlCellTypeVisible).Copy 'change H to whatever your last column is.
        'find the last row on the destination sheet
        DestRows = ws.Range("D" & Rows.Count).End(xlUp).Row
        'paste to the destination sheet
        ws.Cells(DestRows + 1, 1).PasteSpecial
    Next
    'delete everything you've copied
    .Range("A2:H" & LastRow).EntireRow.Delete 'change H to whatever your last column is.
End With
    
End Sub