Macro for Moving Rows to New Tab

New Contributor

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)
            If CStr(xRg(K).Value) = "Done" Then
                K = K - 1
            End If
            J = J + 1
        End If
    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!


2 Replies
best response confirmed by NateFromFun (New Contributor)


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
        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
            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
I can't even say thank you enough!! This worked perfectly!