Macro for Moving Rows to New Tab

[NateFromFun]

Hey there-

Hope you're having a great day so far! I have an excel file that is several thousand lines long. My columns are:

• Item title
• price
• image url
• website category

What I need help with is creating a macro that will look at all of the site categories, and create a new sheet for each unique value, and then move the rows that are within that site category to that new sheet.

I was able to find this macro:

Sub Cheezy()
'Updated by Kutools for Excel 2017/8/28
    Dim xRg As Range
    Dim xCell As Range
    Dim I As Long
    Dim J As Long
    Dim K As Long
    I = Worksheets("Sheet1").UsedRange.Rows.Count
    J = Worksheets("Sheet2").UsedRange.Rows.Count
    If J = 1 Then
       If Application.WorksheetFunction.CountA(Worksheets("Sheet2").UsedRange) = 0 Then J = 0
    End If
    Set xRg = Worksheets("Sheet1").Range("C1:C" & I)
    On Error Resume Next
    Application.ScreenUpdating = False
    For K = 1 To xRg.Count
        If CStr(xRg(K).Value) = "Done" Then
            xRg(K).EntireRow.Copy Destination:=Worksheets("Sheet2").Range("A" & J + 1)
            xRg(K).EntireRow.Delete
            If CStr(xRg(K).Value) = "Done" Then
                K = K - 1
            End If
            J = J + 1
        End If
    Next
    Application.ScreenUpdating = True
End Sub

The problem is that the website categories can change, and I don't want to code the sheet names and values into the script. Is it possible to have it generate the sheet names and move the rows to the appropriate sheet based on unique site categories within a column?

Thank you so much for the help!

-Nate

[#2 · Accepted solution]

@NateFromFun 

Here is a macro. It uses column D as category column. If you are using another column for this, change the constant at the beginning of the code accordingly.

The code assumes that row 1 contains column headings.

Sub SplitData()
    Const strCol = "D" ' the column with categories
    Dim wshS As Worksheet
    Dim wshT As Worksheet
    Dim r As Long
    Dim r0 As Long
    Dim m As Long
    Dim ID
    Application.ScreenUpdating = False
    Set wshS = ActiveSheet
    m = wshS.Range(strCol & Rows.Count).End(xlUp).Row
    wshS.Range("1:" & m).Sort Key1:=wshS.Range(strCol & "1"), Header:=xlYes
    r = 2
    Do
        If wshS.Range(strCol & r).Value <> wshS.Range(strCol & r - 1).Value Then
            Set wshT = Worksheets.Add(After:=Worksheets(Worksheets.Count))
            wshT.Name = wshS.Range(strCol & r).Value
            wshT.Range("1:1").Value = wshS.Range("1:1").Value
            ID = wshS.Range(strCol & r).Value
            r0 = r
            Do While wshS.Range(strCol & r + 1).Value = ID
                r = r + 1
            Loop
            wshT.Range("2:" & r - r0 + 2).Value = wshS.Range(r0 & ":" & r).Value
        End If
        r = r + 1
    Loop Until r > m
    Application.ScreenUpdating = True
End Sub

[#3]

I can't even say thank you enough!! This worked perfectly!