How can I separate these automatically . I have a list about 3000 rows long that

Question

How can I separate these automatically .

I have a list about 3000 rows long that have a listing of Day, Night, Evening and Morning. How can I separate the rows to go in Column B and put them in separate areas alike? Here is a pic, I can upload a spreadsheet if need be. I basically want to put all the Evenings in their own area and the others the same. So, all the Days go together, Nights and Mornings. If you note I have them all grouped together in C:N and then in their own groupls in P:AA, AC:AN and so on. I have a list of 3000 rows to place in column B.

Thank you !!

Here is the other half of the spreadsheet

How can I separate these automatically . I have a list about 3000 rows long that have a listing of Day, Night, Evening and Morning. How can I separate the rows to go in Column B and put them in separate areas alike? Here is a pic, I can upload a spreadsheet if need be. I basically want to put all the Evenings in their own area and the others the same. So, all the Days go together, Nights and Mornings. If you note I have them all grouped together in C:N and then in their own groupls in P:AA, AC:AN and so on. I have a list of 3000 rows to place in column B. Thank you !! Here is the other half of the spreadsheet

Explanation / Answer

Hi..

Hi,

data in active sheet

in row 2 are headers

in cell B2 add/type a header e.g HEADER-B

(make a copy before you run this code)

Sub Split_OverWriteData()
'10 Feb 2015
Const N As Long = 2 '<< headers in row 2
Dim ws As Worksheet
Set ws = ActiveSheet
Dim v As Variant, v1 As Variant
v = Array("Evening", "Day", "Morning", "Night") '<< check the names !!!
v1 = Array(16, 29, 42, 55)
Dim r As Long, r1 As Long, x As Long

r = ws.Cells(Rows.Count, "B").End(xlUp).Row
ws.AutoFilterMode = False
For x = 0 To UBound(v).

If WorksheetFunction.CountIf(ws.Range("B:B"), v(x)) > 0 Then
ws.Range(ws.Cells(N, "B"), ws.Cells(r, "B")).AutoFilter Field:=1, Criteria1:=UCase(v(x));
r1 = ws.Cells(Rows.Count, v1(x)).End(xlUp).Row

If r1 < N + 1 Then r1 = N + 1

ws.Cells(N + 1, v1(x)).Resize(r1, 12).ClearContents
ws.Cells(N + 1, "C").Resize(r , 12).SpecialCells(xlCellTypeVisible).Copy ws.Cells(N + 1, v1(x))
End If
Next x
ws.AutoFilterMode = False.
End Sub

Related Questions

Navigate

• Browse (All)
• Browse H
• Subjects

---

---

Integrity-first tutoring: explanations and feedback only — we do not complete graded work. Learn more.