SOLVED

Highlighted
New Contributor

# Macro for Moving Rows to New Tab

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 Replies
Highlighted
Best Response confirmed by NateFromFun (New Contributor)
Solution

# Re: Macro for Moving Rows to New Tab

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
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

# Re: Macro for Moving Rows to New Tab

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