Created multiple sheets from cell value and template, would like to add other data to it

B

bastoe

New Member
Joined
Aug 17, 2010
Messages
9
Hi, folks, asking for some advice on how to do this. I have some vba code from another thread here, and was hoping more could be done while it's creating these sheets.

My Data sheet has data in Cols A:H with Col C being the sheet name values. (see pic)

What's needed is to copy matching cell/col values on the data sheet, transpose those to rows on the new sheets being created.
Secondary: The template copied to the new sheet contains 48 columns, and I would like to delete any that won't be used.
(the unused columns on the new sheets won't have data in rows 2 or 3 by that point)

So if values in Col F are in the same row as the Sheet name from Col C, copy those Col F values to the new sheet transposed across the Top Row.
Then do the same with Col D and copy transpose them to Row 2
Then do the same with Col H and copy transpose them to Row 3

The Group column can contain letters and numbers and sometimes both
The Ser # only column can contain / slashes
There could be up to 70 new sheets created.

Example sheet: Col C are sheet names, Copy corresponding Col values F, D, & H and transpose to new sheet, rows 1, 2, & 3
1650133640019.png

(not the word Row 1, 2, 3, just the values copied)

Thanks to mumps, for this excellent code. I changed it to use Column C for my data.
Right now the code is creating new sheets based on Col C City names, and copying a template to it (the template data starts in row 6, using 48 columns)

VBA Code: 
Sub CreateSheets()
[COLOR=rgb(97, 189, 109)]'//code by mumps from mrexcel.com//[/COLOR]
    Application.ScreenUpdating = False
    Dim i As Long, v As Variant, wsName As String
    Sheets("Data").Visible = True
    v = Sheets("Data").Range("C2", Sheets("Data").Range("C" & Rows.Count).End(xlUp)).Value
    With CreateObject("Scripting.Dictionary")
        For i = 1 To UBound(v, 1)
            wsName = Replace(Left(v(i, 1), 31), "/", " ")
            If Not .Exists(wsName) Then
                .Add wsName, Nothing
                If Not Evaluate("isref('" & wsName & "'!C1)") Then
                    Sheets("Template Sheet").Copy after:=Sheets(Sheets.Count)
                    ActiveSheet.Name = wsName
                 [COLOR=rgb(97, 189, 109)] '  Range("B1") = wsName [/COLOR]  [COLOR=rgb(147, 101, 184)]    '//<-----so here instead of this, make it do the 3 new rows...Starting A1, A2, A3//[/COLOR]
                End If
            End If
        Next i
    End With
   [COLOR=rgb(97, 189, 109)] 'Sheets("Data").Visible = xlHidden '//not using//[/COLOR]
    Application.ScreenUpdating = True
End Sub


Thanks for any assistance!
 

Excel Facts

How to show all formulas in Excel?
Press Ctrl+` to show all formulas. Press it again to toggle back to numbers. The grave accent is often under the tilde on US keyboards.
Sort by date Sort by votes
Oop, it put color tags instead of changing the color, so here's the code without the extras it added:

VBA Code: 
Sub CreateSheets()
'//code by mumps from mrexcel.com//
    Application.ScreenUpdating = False
    Dim i As Long, v As Variant, wsName As String
    Sheets("Data").Visible = True
    v = Sheets("Data").Range("C2", Sheets("Data").Range("C" & Rows.Count).End(xlUp)).Value
    With CreateObject("Scripting.Dictionary")
        For i = 1 To UBound(v, 1)
            wsName = Replace(Left(v(i, 1), 31), "/", " ")
            If Not .Exists(wsName) Then
                .Add wsName, Nothing
                If Not Evaluate("isref('" & wsName & "'!C1)") Then
                    Sheets("Template Sheet").Copy after:=Sheets(Sheets.Count)
                    ActiveSheet.Name = wsName
            Range("B1") = wsName     '//<-----so here instead of this, make it do the 3 new rows...Starting A1, A2, A3//
                End If
            End If
        Next i
    End With
  'Sheets("Data").Visible = xlHidden '//not using//
    Application.ScreenUpdating = True
End Sub
 
Upvote 0
It is hard to work with pictures. It would be easier to help if you could use the XL2BB add-in (icon in the menu) to attach a screenshot (not a picture) of your sheet. Alternately, you could upload a copy of your file to a free site such as www.box.com or www.dropbox.com. Once you do that, mark it for 'Sharing' and you will be given a link to the file that you can post here. Explain in detail what you want to do referring to specific cells, rows, columns and sheets using a few examples from your data (de-sensitized if necessary).
 
Upvote 0
mumps said:
It is hard to work with pictures. It would be easier to help if you could use the XL2BB add-in (icon in the menu) to attach a screenshot (not a picture) of your sheet. Alternately, you could upload a copy of your file to a free site such as www.box.com or www.dropbox.com. Once you do that, mark it for 'Sharing' and you will be given a link to the file that you can post here. Explain in detail what you want to do referring to specific cells, rows, columns and sheets using a few examples from your data (de-sensitized if necessary).
Click to expand...
Hi mumps, it's been awhile since I got to do anything with Excel. Not since a few years after my join date actually. Anyway per your request, I uploaded the sample workbook Here and redid the ask, hopefully a little clearer.

Specifically for each new sheet:
If values in Col F are in the same row as the Sheet name from Col C, copy those Col F values to that new sheet transposed across the Top Row.
If values in Col D are in the same row as the Sheet name from Col C, copy those Col D values to that new sheet transposed across the Second Row.
If values in Col H are in the same row as the Sheet name from Col C, copy those Col H values to that new sheet transposed across the Third Row.

Then delete the unused columns (the unused columns on the new sheets won't have data in rows 2 or 3 by that point) See attachment for example.

The Group column can contain letters and numbers and sometimes both
The Ser # only column can contain / slashes
There could be up to 70 new sheets created, which is the why this needs to be done, saving tons of work.

Example of what's needed is attached: Col C are sheet names, Corresponding Col values in F, D, & H are transposed to new sheets in rows 1, 2, & 3. I left some sample template data with notes.

Thank you mumps, for this excellent code. It does exactly what you designed it to do.
(it creates new sheets based on Col C City names, and copies a template to it, the template data starts in row 6, using 48 columns)

VBA Code:
VBA Code: 
Sub CreateSheets()
'//code by mumps from mrexcel.com//
Application.ScreenUpdating = False
Dim i As Long, v As Variant, wsName As String
Sheets("Data").Visible = True
v = Sheets("Data").Range("C2", Sheets("Data").Range("C" & Rows.Count).End(xlUp)).Value
With CreateObject("Scripting.Dictionary")
For i = 1 To UBound(v, 1)
wsName = Replace(Left(v(i, 1), 31), "/", " ")
If Not .Exists(wsName) Then
.Add wsName, Nothing
If Not Evaluate("isref('" & wsName & "'!C1)") Then
Sheets("Template").Copy after:=Sheets(Sheets.Count)
ActiveSheet.Name = wsName
  Range("B1") = wsName    '//<-----so here instead of this, make it do the 3 rows of corresponding data...//
End If
End If
 Next i
End With
 'Sheets("Data").Visible = xlHidden '//not using//
Application.ScreenUpdating = True
End Sub

Thanks for any assistance!
 
Upvote 0
Try:
VBA Code: 
Sub CreateSheets()
'//code by mumps from mrexcel.com//
    Application.ScreenUpdating = False
    Dim i As Long, v As Variant, wsName As String, RowCount As Long, srcWS As Worksheet, fVisRow As Long, lVisRow As Long
    Set srcWS = Sheets("Data")
    srcWS.Visible = True
    v = srcWS.Range("C2", srcWS.Range("C" & Rows.Count).End(xlUp)).Resize(, 6).Value
    With CreateObject("Scripting.Dictionary")
        For i = 1 To UBound(v, 1)
            If Not .exists(v(i, 1)) Then
                .Add v(i, 1), Nothing
                If Not Evaluate("isref('" & v(i, 1) & "'!A1)") Then
                    With srcWS
                        .Cells(1).AutoFilter 3, v(i, 1)
                        fVisRow = .Range("A2", .Range("A" & .Rows.Count).End(xlUp)).SpecialCells(xlCellTypeVisible).Cells(1, 1).Row
                        lVisRow = .Cells(Rows.Count, "A").End(xlUp).Row
                        RowCount = .[subtotal(103,A:A)] - 1
                        Sheets("Template").Copy after:=Sheets(Sheets.Count)
                        ActiveSheet.Name = v(i, 1)
                        .Range("F" & fVisRow & ":F" & lVisRow).SpecialCells(xlCellTypeVisible).Copy
                        Range("A1").PasteSpecial xlPasteValues, Transpose:=True
                        .Range("D" & fVisRow & ":D" & lVisRow).SpecialCells(xlCellTypeVisible).Copy
                        Range("A2").PasteSpecial xlPasteValues, Transpose:=True
                        .Range("H" & fVisRow & ":H" & lVisRow).SpecialCells(xlCellTypeVisible).Copy
                        Range("A3").PasteSpecial xlPasteValues, Transpose:=True
                        Cells(1, RowCount + 1).Resize(, 48 - RowCount).EntireColumn.Delete
                    End With
                End If
            End If
        Next i
    End With
    Sheets("Data").Range("A1").AutoFilter
    Application.CutCopyMode = False
    Application.ScreenUpdating = True
End Sub
 
Upvote 0
You are a genius!!

There's an error that made it stop, but it may be an easy fix. I have some Cities where it's only one row of data for that city, every city that had more than one row copied perfectly.

My guess, is that since it's copying just one cell of data, there is no transpose for it? Would be the same fix for all three ranges of F, D, and H maybe.

runtime1004.png


Debug just shows this line:

runtimedebug.png


Thanks for this, we're almost there.
 
Upvote 0
Try:
VBA Code: 
Sub CreateSheets()
'//code by mumps from mrexcel.com//
    Application.ScreenUpdating = False
    Dim i As Long, v As Variant, wsName As String, RowCount As Long, srcWS As Worksheet, fVisRow As Long, lVisRow As Long
    Set srcWS = Sheets("Data")
    srcWS.Visible = True
    v = srcWS.Range("C2", srcWS.Range("C" & Rows.Count).End(xlUp)).Resize(, 6).Value
    With CreateObject("Scripting.Dictionary")
        For i = 1 To UBound(v, 1)
            If Not .exists(v(i, 1)) Then
                .Add v(i, 1), Nothing
                If Not Evaluate("isref('" & v(i, 1) & "'!A1)") Then
                    With srcWS
                        .Cells(1).AutoFilter 3, v(i, 1)
                        fVisRow = .Range("A2", .Range("A" & .Rows.Count).End(xlUp)).SpecialCells(xlCellTypeVisible).Cells(1, 1).Row
                        lVisRow = .Cells(Rows.Count, "A").End(xlUp).Row
                        RowCount = .[subtotal(103,A:A)] - 1
                        If RowCount = 1 Then
                            Sheets("Template").Copy after:=Sheets(Sheets.Count)
                            ActiveSheet.Name = v(i, 1)
                            Range("A1").Value = .Range("F" & lVisRow).Value
                            Range("A2").Value = .Range("D" & lVisRow).Value
                            Range("A3").Value = .Range("H" & lVisRow)
                            Cells(1, RowCount + 1).Resize(, 48 - RowCount).EntireColumn.Delete
                        Else
                            Sheets("Template").Copy after:=Sheets(Sheets.Count)
                            ActiveSheet.Name = v(i, 1)
                            .Range("F" & fVisRow & ":F" & lVisRow).SpecialCells(xlCellTypeVisible).Copy
                            Range("A1").PasteSpecial xlPasteValues, Transpose:=True
                            .Range("D" & fVisRow & ":D" & lVisRow).SpecialCells(xlCellTypeVisible).Copy
                            Range("A2").PasteSpecial xlPasteValues, Transpose:=True
                            .Range("H" & fVisRow & ":H" & lVisRow).SpecialCells(xlCellTypeVisible).Copy
                            Range("A3").PasteSpecial xlPasteValues, Transpose:=True
                            Cells(1, RowCount + 1).Resize(, 48 - RowCount).EntireColumn.Delete
                        End If
                    End With
                End If
            End If
        Next i
    End With
    Sheets("Data").Range("A1").AutoFilter
    Application.CutCopyMode = False
    Application.ScreenUpdating = True
End Sub
 
Upvote 0
Solution
mumps said:
Try:
VBA Code: 
Sub CreateSheets()
'//code by mumps from mrexcel.com//
    Application.ScreenUpdating = False
    Dim i As Long, v As Variant, wsName As String, RowCount As Long, srcWS As Worksheet, fVisRow As Long, lVisRow As Long
    Set srcWS = Sheets("Data")
    srcWS.Visible = True
    v = srcWS.Range("C2", srcWS.Range("C" & Rows.Count).End(xlUp)).Resize(, 6).Value
    With CreateObject("Scripting.Dictionary")
        For i = 1 To UBound(v, 1)
            If Not .exists(v(i, 1)) Then
                .Add v(i, 1), Nothing
                If Not Evaluate("isref('" & v(i, 1) & "'!A1)") Then
                    With srcWS
                        .Cells(1).AutoFilter 3, v(i, 1)
                        fVisRow = .Range("A2", .Range("A" & .Rows.Count).End(xlUp)).SpecialCells(xlCellTypeVisible).Cells(1, 1).Row
                        lVisRow = .Cells(Rows.Count, "A").End(xlUp).Row
                        RowCount = .[subtotal(103,A:A)] - 1
                        If RowCount = 1 Then
                            Sheets("Template").Copy after:=Sheets(Sheets.Count)
                            ActiveSheet.Name = v(i, 1)
                            Range("A1").Value = .Range("F" & lVisRow).Value
                            Range("A2").Value = .Range("D" & lVisRow).Value
                            Range("A3").Value = .Range("H" & lVisRow)
                            Cells(1, RowCount + 1).Resize(, 48 - RowCount).EntireColumn.Delete
                        Else
                            Sheets("Template").Copy after:=Sheets(Sheets.Count)
                            ActiveSheet.Name = v(i, 1)
                            .Range("F" & fVisRow & ":F" & lVisRow).SpecialCells(xlCellTypeVisible).Copy
                            Range("A1").PasteSpecial xlPasteValues, Transpose:=True
                            .Range("D" & fVisRow & ":D" & lVisRow).SpecialCells(xlCellTypeVisible).Copy
                            Range("A2").PasteSpecial xlPasteValues, Transpose:=True
                            .Range("H" & fVisRow & ":H" & lVisRow).SpecialCells(xlCellTypeVisible).Copy
                            Range("A3").PasteSpecial xlPasteValues, Transpose:=True
                            Cells(1, RowCount + 1).Resize(, 48 - RowCount).EntireColumn.Delete
                        End If
                    End With
                End If
            End If
        Next i
    End With
    Sheets("Data").Range("A1").AutoFilter
    Application.CutCopyMode = False
    Application.ScreenUpdating = True
End Sub
Click to expand...
Brilliantly done!!! Works perfectly!!! huge thank you mumps!
 
Upvote 0
You must log in or register to reply here.

Similar threads

P
  • Question Question
Checking for Worksheets that already exist
2
Replies
11
Views
383
Logit
Logit
N
  • Question Question
Pivot graph data when creating a new tab from a template.
Replies
0
Views
258
Nippyzap
N
Z
  • Question Question
Vba - create new sheet and copy date into it.
Replies
1
Views
104
zerofeng
Z
O
  • Solved
Copy a sheet which is a template based on a drop down list and rename each copied tab with each value in the drop down list
2 3
Replies
21
Views
1K
dmt32
D
S
  • Question Question
Creating new sheets from template sheet plugging data into new sheets with particular criterias
Replies
1
Views
712
mumps
mumps

Forum statistics

Threads
1,224,817
Messages
6,181,149
Members
453,021
Latest member
Justyna P

Share this page

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top