Move rows to existing/new worksheet based on cell value

Question

what I need is fairly simple but I can't for the life of me figure out how to write this in code. I tried looking around for a macro that could do this, but so far no luck.

I have a workbook with one worksheet that contains raw data and 30 or so worksheets for different customers. Each row in the raw data worksheet has the name of the customer in column I.

I need to make a macro that cuts and pastes each row to the worksheet of the respective customer, for example if I2=CustomerA, move that row to the end of sheet CustomerA. Also some customers don't have worksheets yet because they're new, so for example if I5=CustomerZ but worksheet CustomerZ not found, create it and then move the row.

Unknown Unknown · Accepted Answer · 2013-07-01T08:41:13

All you really have to do is set your :
sh33tName so it matches your master worksheet
custNameColumn so it matches your column name with the customers names
stRow row at which the customer names start

Option Explicit

Sub Fr33M4cro()

    Dim sh33tName As String
    Dim custNameColumn As String
    Dim i As Long
    Dim stRow As Long
    Dim customer As String
    Dim ws As Worksheet
    Dim sheetExist As Boolean
    Dim sh As Worksheet

    sh33tName = "Sheet1"
    custNameColumn = "I"
    stRow = 2

    Set sh = Sheets(sh33tName)

    For i = stRow To sh.Range(custNameColumn & Rows.Count).End(xlUp).Row
        customer = sh.Range(custNameColumn & i).Value
        For Each ws In ThisWorkbook.Sheets
            If StrComp(ws.Name, customer, vbTextCompare) = 0 Then
                sheetExist = True
                Exit For
            End If
        Next
        If sheetExist Then
            CopyRow i, sh, ws, custNameColumn
        Else
            InsertSheet customer
            Set ws = Sheets(Worksheets.Count)
            CopyRow i, sh, ws, custNameColumn
        End If
        Reset sheetExist
    Next i

End Sub

Private Sub CopyRow(i As Long, ByRef sh As Worksheet, ByRef ws As Worksheet, custNameColumn As String)
    Dim wsRow As Long
    wsRow = ws.Range(custNameColumn & Rows.Count).End(xlUp).Row + 1
    sh.Rows(i & ":" & i).Copy
    ws.Rows(wsRow & ":" & wsRow).PasteSpecial _
    Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
    Application.CutCopyMode = False
End Sub

Private Sub Reset(ByRef x As Boolean)
    x = False
End Sub

Private Sub InsertSheet(shName As String)
    Worksheets.Add(After:=Worksheets(Worksheets.Count)).Name = shName
End Sub

Move rows to existing/new worksheet based on cell value

1 Answers