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]

here's a VBA code to try. start sheet is Sheet1, but easily modified if need be

Sub sheets_from_colD() 

Const cl& = 4
Dim a As Variant, x As Worksheet, sh As Worksheet
Dim rws&, cls&, p&, i&, rr&, b As Boolean
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)
                Sheets.Add.Name = a(p, cl)
                With Sheets(a(p, cl))
                    x.Cells(1).Resize(, cls).Copy .Cells(1)
                    rr = .Cells.Find("*", , , , xlByRows, xlPrevious).Row + 1
                    x.Cells(p, 1).Resize(i - p, cls).Cut .Cells(rr, 1)
                End With
            End If
            p = i
        End If
    Next i
Application.DisplayAlerts = False
    x.Delete
Application.DisplayAlerts = True
Application.ScreenUpdating = True


End Sub

 

[fauncefus]

It is almost there but I am getting an run time error 1004 stating that "You typed an invalid name for a sheet or chart. Make sure that the name does not exceed 31 characters. The name does not contain any of the following characters : \ / ? * [ ]
You didn't leave the name blank.
The process is stopping at this line of code: Sheets.Add.Name=a(p,cl)

I have checked all of my names and have replaced all of my \ in the one column (not the vendor names) to - . What else could it be?

 

[mirabeau]

It is almost there but I am getting an run time error 1004 stating that "You typed an invalid name for a sheet or chart. Make sure that the name does not exceed 31 characters. The name does not contain any of the following characters : \ / ? * [ ]
You didn't leave the name blank.
The process is stopping at this line of code: Sheets.Add.Name=a(p,cl)

I have checked all of my names and have replaced all of my \ in the one column (not the vendor names) to - . What else could it be?

It's only column D that is used to name new sheets. Symbols such as \ etc.in other columns shouldn't matter.

I've used that code a number of times it's always worked for me.

So, suggestions:
Do you have any merged cells? Those may cause problems for my posted code.

Try it on some test data generated by a code such as that below (use it in a new workbook, Sheet1) to see if it works with that.

Do any of your entries in Col D (vendor names) have more than 31 characters? If so then may need to modify the renaming (easy enough to do) such as just giving numbers or other unique coding to the new sheets, or truncating the Col D entries to fewer characters.

Without seeing your data it's hard to be more specific, but anyway try the code below to generate a simple dataset and see if my Post#2 code works for you with that one.

There's also a delete_sheet() code if you want to easily delete all sheets except "Sheet1".

Sub test_data()
Sheets("Sheet1").Activate
ActiveSheet.UsedRange.ClearContents
Const n As Long = 10
With Cells(1).Resize(n, 5)
    .Cells = "=char(int(rand()*26)+65)&randbetween(1,9)"
    .Resize(, 1).Offset(, 3) = "=rept(char(int(rand()*3)+65),3)"
    .Resize(1) = "=""Col"" & column()"
    .Value = .Value
End With
Cells(4) = "NAME"
End Sub

Sub delete_sheets()
Dim ws As Worksheet
Application.DisplayAlerts = False
For Each ws In Worksheets
    If Not ws.Name = "Sheet1" Then ws.Delete
Next ws
Application.DisplayAlerts = True
End Sub

 

[fauncefus]

<!--[if gte mso 9]><xml> <o:OfficeDocumentSettings> <o:AllowPNG/> </o:OfficeDocumentSettings> </xml><![endif]--> Can you show me how to combine these two codes? I am getting an error if I just add the first code to the second one.

Here is the one to split the sheets and name them:

Sub sheets_from_colD() 

  
  Const cl& = 4
  Dim a As Variant, x As Worksheet, sh As Worksheet
  Dim rws&, cls&, p&, i&, rr&, b As Boolean
  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)
                  Sheets.Add.Name = a(p, cl)
                  With Sheets(a(p, cl))
                      x.Cells(1).Resize(, cls).Copy .Cells(1)
                      rr = .Cells.Find("*", , , , xlByRows, xlPrevious).Row + 1
                      x.Cells(p, 1).Resize(i - p, cls).Cut .Cells(rr, 1)
                  End With
              End If
              p = i
          End If
      Next i
  Application.DisplayAlerts = False
      x.Delete
  Application.DisplayAlerts = True
  Application.ScreenUpdating = True
  
  
  End Sub

 

[fauncefus]

This one goes through all rows and adds a blank line when there is a change. I need to combine both codes to work in all worksheets in a workbook. Any idea?

  Public Sub Insert_Row()
      Dim rng As Range
      Dim LR As Long
      Dim i As Integer
      Application.ScreenUpdating = False
      LR = Range("C" & Rows.Count).End(xlUp).Row
      ' Assumes a Header Row
      Set rng = Range("C2:C" & LR)
      With rng
          For i = LR To 2 Step -1
              If Not rng(i).Value = rng(i).Offset(-1, 0).Value Then
                  rng(i).EntireRow.Insert
              End If
          Next
      End With
      Application.ScreenUpdating = True
  End Sub

 

[mirabeau]

I'm currently somewhat unclear about just where you are now and where you're going.

The posts I've made so far on this thread:
1. Respond to the title: "Need VBA to Add New Sheets, Name them and Copy Rows based on one columns information". So I posted a code that does just that.

2. You indicate error message. So I posted a testdata code and made some suggestions towards tracking down and resolving any errors. Did this help?

3. After this I don't know what's happened. Are you still getting errors? If so, what and where? Why should you want to combine codes? Which ones? What is your current situation and where from here??

 

[fauncefus]

Sorry for not being more clear. I found my error and it was one vendors name that was stopping the whole macro. Fixed that and the code works great! Thank you! Before this code was made I would run the code I just posted on my main sheet and cut and paste each vendor to their own tab. That code adds a blank row in between each date and item change. It works independently but when I try to incorporate it into the code you wrote I can figure out where to place it. I need it to run through each worksheet independently. Can this be done or is it too much?

 

[mirabeau]

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

 

[timmorris]

Hello,
I have run into a situation where copying the names from one of the column into a new sheet would be great for me. I am able to do this with the code you give above, except my header is two rows instead of one.

How would I be able to copy the first two rows into each of the new sheets while keeping all of the rest in tact...I tried to do it by using rws + 2 and .Row +2, which is a start, but it isn't copying row #2 in. I also figured out to switch "Const cl& = 2" because my names that I want the sheets named after are from column B. I also changed "Sheet1" to "General" because that is the name of my first sheet.

Thanks!

Here is the code I have so far:

Sub Invoice()


Const cl& = 2
' 2 above is column 2, meaning it is naming the new worksheets based off of column 2
Dim a As Variant, x As Worksheet, sh As Worksheet
Dim rws&, cls&, p&, i&, rr&, b As Boolean
Application.ScreenUpdating = False
Sheets("General").Activate
rws = Cells.Find("*", , , , xlByRows, xlPrevious).Row
cls = Cells.Find("*", , , , xlByColumns, xlPrevious).Column
Set x = Sheets.Add(After:=Sheets("General"))
Sheets("General").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 + 2)
' In the "rws +2" this means it will start at row 3
    p = 2
    For i = p To rws + 2
' In the "rws +2" this means it will start at row 3
        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)
                Sheets.Add.Name = a(p, cl)
                With Sheets(a(p, cl))
                x.Cells(1).Resize(, cls).Copy .Cells(1)
' The (1) and .Cells(1) above refer to B1, if you have this at 2, it will start at B1 copying
                    rr = .Cells.Find("*", , , , xlByRows, xlPrevious).Row + 2
' In the .Row +2 this means it will start at row 3
                    x.Cells(p, 1).Resize(i - p, cls).Cut .Cells(rr, 1)
' The rr, 3 means it adds two blank columns below row 3
                End With
            End If
            p = i
        End If
    Next i
Application.DisplayAlerts = False
    x.Delete
Application.DisplayAlerts = True
Application.ScreenUpdating = True




End Sub