Need VBA to Add New Sheets, Name them and Copy Rows based on one columns information

[fauncefus]

Hello All,
I have been slowly learning to build Macros and cannot seem to comprehend enough to tie it all together for this project. I have a worksheet with 85 Vendors (currently but will grow) all in column D. My worksheet varies from week to week but can be 5000 rows at times and will continue to grow and Columns A-I have all the information I need to copy to the new sheets.

I am looking to have a macro that will when run go through the 5,000 rows, create new worksheets for each vendor and copy all rows from the vendor to his sheet. Alphabetically would be ideal but I don't want to push my luck.

Can anyone help me with the coding?

 

[mirabeau]

@tim

does this one work Ok for you

Sub col_to_new_sheetx()

Const cl& = 4
Const ss As String = "General"  'name of start sheet

Dim a As Variant, x As Worksheet, sh As Worksheet
Dim rws&, cls&, p&, i&, ri&, j&
Dim b As Boolean

Sheets(ss).Activate
rws = Cells.Find("*", , , , xlByRows, xlPrevious).Row
cls = Cells.Find("*", , , , xlByColumns, xlPrevious).Column

Set x = Sheets.Add(After:=Sheets(ss))
Sheets(ss).Cells(3, 1).Resize(rws - 2, cls).Copy x.Cells(1)
Set a = x.Cells(1).Resize(rws, cls)
a.Sort a(1, cl), 2, Header:=xlNo
a = a.Resize(rws + 1)
p = 1

For i = p To rws + 1
    If a(i, cl) <> a(p, cl) Then
        b = False
        For Each sh In Worksheets
            If sh.Name = a(p, cl) Then b = True: Exit For
        Next
        If Not b Then
            Sheets.Add.Name = a(p, cl)
            With Sheets(a(p, cl))
                x.Cells(1).Resize(, cls).Copy .Cells(3, 1)
                ri = i - p
                x.Cells(p, 1).Resize(ri, cls).Cut .Cells(3, 1)
                Sheets(ss).Cells(1).Resize(2, cls).Copy .Cells(1)
            End With
        End If
        p = i
    End If
Next i

Application.DisplayAlerts = False
    x.Delete
Application.DisplayAlerts = True

End Sub

 

[timmorris]

Hello MiraBeau! Thanks for your quick response.
I tried the code the way you have it, but it wasn't doing anything. I compared it closely to the other code and noticed that line #7 had some typos or somehow I fixed it...I replaced

<code>
Dim rws&, cls&, p&, i&, ri&, j&
</code>

with

<code>
Dim rws&, cls&, p&, i&, rr&, j&
</code>

The "ri&" needed replaced with "rr&" and that worked.

Also, do you know how I could add a way for the other sheets that I create from "general" to keep the same width and height on the rows and columns as "General"?

Thanks a ton for all of your help!

 

[Cobc54]

Mirabeau,

I am looking for a simpler variation of the code that you provided. I am looking to do exactly what this code does except I need all of the new copied sheets to be identical to "sheet1" but the new sheet names are based on values in column D on another sheet (Sheet2). I would greatly appreciate any help you can lend...please advise

thanks

 

[Busiga]

You can try this code.

It creates new sheets from each unique value in column D of Sheet1, and in each new sheet, puts a spacing line where the values in Col C (dates?) change.

Is this what you want? The columns D and C can be changed as you like (at the top of the code).

Sub col_to_new_sheet()

Const cl& = 4
Const datz& = 3

Dim a As Variant, x As Worksheet, sh As Worksheet
Dim rws&, cls&, p&, i&, ri&, j&
Dim u(), b As Boolean, y

Application.ScreenUpdating = False
Sheets("Sheet1").Activate
rws = Cells.Find("*", , , , xlByRows, xlPrevious).Row
cls = Cells.Find("*", , , , xlByColumns, xlPrevious).Column

Set x = Sheets.Add(After:=Sheets("Sheet1"))
Sheets("Sheet1").Cells(1).Resize(rws, cls).Copy x.Cells(1)
Set a = x.Cells(1).Resize(rws, cls)
a.Sort a(1, cl), 2, Header:=xlYes
a = a.Resize(rws + 1)
p = 2

For i = p To rws + 1
    If a(i, cl) <> a(p, cl) Then
        b = False
        For Each sh In Worksheets
            If sh.Name = a(p, cl) Then b = True: Exit For
        Next
        If Not b Then
            Sheets.Add.Name = a(p, cl)
            With Sheets(a(p, cl))
                x.Cells(1).Resize(, cls).Copy .Cells(1)
                ri = i - p
                x.Cells(p, 1).Resize(ri, cls).Cut .Cells(2, 1)
                .Cells(2, 1).Resize(ri, cls).Sort .Cells(2, datz), Header:=xlNo
                y = .Cells(datz).Resize(ri + 1)
                ReDim u(1 To 2 * ri, 1 To 1)
                For j = 2 To ri
                    u(j, 1) = j
                    If y(j, 1) <> y(j + 1, 1) Then u(j + ri, 1) = j
                Next j
                .Cells(cls + 1).Resize(2 * ri) = u
                .Cells(1).Resize(2 * ri, cls + 1).Sort .Cells(cls + 1), Header:=xlYes
                .Cells(cls + 1).Resize(2 * ri).ClearContents
            End With
        End If
        p = i
    End If
Next i


Application.DisplayAlerts = False
    x.Delete
Application.DisplayAlerts = True
Application.ScreenUpdating = True


End Sub

Hi, this code is exactly what im looking for.

Tho i cant get it to work correctly for me.
My sheet looks like this and i want to get a new sheet for all agent and copy the SR number to each sheet that belongs to that specific user.
Any clue what i need to change?

 

[Busiga]

Might add that i have changed
Const cl& = 2
Const datz& = 1
but getting error on
a.Sort a(1, cl), 2, Header:=xlYes
witch i dont understand what it does anyway