Sep 29 2020 08:21 AM
Sep 29 2020 08:21 AM
Hope you're having a great day so far! I have an excel file that is several thousand lines long. My columns are:
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!
Sep 29 2020 12:02 PMSolution
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