Fellow VBA Wizards,
Using the following code, I was able to generate multiple sheets with tab names equal to a dynamic range:
Sub SheetMacro()
Dim MyCell As Range, MyRange As Range
Set MyRange = Sheets("Control_Sheet").Range("F7")
Set MyRange = Range(MyRange, MyRange.End(xlDown))
For Each MyCell In MyRange
Sheets.Add After:=Sheets(Sheets.Count) 'creates a new worksheet
Sheets(Sheets.Count).Name = MyCell.Value ' renames the new worksheet
Next MyCell
End Sub
I'm running into a bit of a snag when attempting to copy a source template w/formulas (EAC Summary) into all recently created sheets. Adding this code duplicates the EAC Summary, but it does not name the tabs within the dynamic range:
Sub SheetMacro()
Dim MyCell As Range, MyRange As Range
Dim ws1 As Worksheet
Set MyRange = Sheets("Control_Sheet").Range("F7")
Set MyRange = Range(MyRange, MyRange.End(xlDown))
For Each MyCell In MyRange
Sheets.Add After:=Sheets(Sheets.Count) 'creates a new worksheet
Sheets(Sheets.Count).Name = MyCell.Value ' renames the new worksheet
Set ws1 = ThisWorkbook.Worksheets("EAC Summary")
ws1.Copy ThisWorkbook.Sheets(Sheets.Count)
Next MyCell
End Sub
Is there an optimal method to combine the code in such a way to replicate the source template, and name the tabs according to inputs in the dynamic range?
Thanks in advance.
I was able utilize an alternative command for copying, which resolved my initial question. Here is the code, for anyone that may run into this going forward:
Sub SheetMacro3()
Dim MyCell As Range, MyRange As Range
Set MyRange = Sheets("Control_Sheet").Range("F7")
Set MyRange = Range(MyRange, MyRange.End(xlDown))
Sheets("EAC Summary").Visible = True 'displays master template
For Each MyCell In MyRange
Sheets("EAC Summary").Copy After:=Worksheets(Worksheets.Count)
Sheets(Sheets.Count).Name = MyCell.Value ' renames the new worksheet
Next MyCell
Sheets("EAC Summary").Visible = False 'hides master template
End Sub
Related
I'm trying to copy and paste a certain value from a cell in one sheet matching a range in another workbook. The code runs fine, doesn't give any run-time errors, but will not paste in the range declared in the other workbook. Code below
Sub ConditionalCopy()
Dim dest As Worksheet
Set dest = ActiveWorkbook.Worksheets("VCP Plan")
Dim rng As Range, cell As Range
Set rng = Range("D:D")
Dim OpenWorkBook As Variant
OpenWorkBook = Application.GetOpenFilename("Excel Files (*.xlsx* (*.xlsx*),")
If OpenWorkBook <> False Then
Workbooks.Open (OpenWorkBook)
End If
For Each cell In rng
If cell.Value = "26ASA00015D007" Then
cell.Offset(0, 3).Copy Destination:=dest.Range("E3")
End If
Next cell
End Sub
It is unclear from your description and your code which workbook/worksheet you want to compare and copy, and which workbook/worksheet you want to copy to.
You'll need to be more specific
I've made a guess at what you are trying to do. If I've got it wrong, simply adjust the references to suit
Something like
Sub ConditionalCopy()
Dim wbSource as Workbook
Dim wsSource as Worksheet
Dim rSource as Range
Dim wbDest as Workbook
Dim wsDest as Worksheet
Dim rDest as Range
Set wbDest = ActiveWorkbook ' Are you sure?
Set wsDest = wbDest.Worksheets("VCP Plan")
Set rDest = ws.Range("E3")
Dim OpenWorkBook As Variant
OpenWorkBook = Application.GetOpenFilename("Excel Files (*.xlsx* (*.xlsx*),")
If OpenWorkBook <> False Then
Set wbSource = Workbooks.Open(OpenWorkBook)
Else
Exit Sub
End If
Set wsSource = wbSource.Worksheets("NameOfSourceSheet")
Dim cell As Range
With wsSource
' Column D from row 1 to last used row
Set rSource = .Range(.Cells(1, 4), .Cells(.Rows.Count, 4).End(xlUp))
End With
For Each cell In rSource
If cell.Value = "26ASA00015D007" Then
cell.Offset(0, 3).Copy Destination:=rDest
' You probably don't want to overwrite each time, so
Set rDest = rDest.Offset(1, 0)
End If
Next cell
End Sub
I have a main worksheet (Install_Input) where sheet number, test section, and material are manually entered by user.
(Below: illustration of Install_Input ws: Range A1:C8)
Sheet# | TestSection | Material
.....1.....|..........A..........|.STEEL.|
.....2.....|..........B..........|.PLASTIC.|
.....3.....|..........C..........|.STEEL.|
.....5.....|..........G..........|.STEEL.|
.....2.....|..........F..........|.PLASTIC.|
.....2.....|..........A..........|.STEEL.|
.....5.....|..........D..........|.PLASTIC.|
I want to generate sheets within the current workbook that correspond to sheet numbers entered in Install_Input. The code I made will generate a new sheet for each value in MyRange, however, I would like for my code to skip over generating sheets that already exist. I tried using the "On Error Resume Next" and "On Error GoTo 0" commands to solve this problem, but they just generated unnamed sheets to compensate for those that already exist.
Sub Consolidate_Sheets()
Dim MyCell As Range
Dim MyRange As Range
Dim ws As Worksheet
Set MyRange = Sheets("Install_Input").Range("A2")
Set MyRange = Range(MyRange, MyRange.End(xlDown))
For Each MyCell In MyRange
If Sheets(Sheets.Count).Name <> MyCell.Value Then
'On Error Resume Next
Sheets.Add After:=Sheets(Sheets.Count)
Sheets(Sheets.Count).Name = MyCell.Value
'On Error GoTo 0
End If
Next MyCell
End Sub
You can use the following two functions:
Function getSheetWithDefault(name As String, Optional wb As Excel.Workbook) As Excel.Worksheet
If wb Is Nothing Then
Set wb = ThisWorkbook
End If
If Not sheetExists(name, wb) Then
wb.Worksheets.Add(After:=wb.Worksheets(wb.Worksheets.Count)).name = name
End If
Set getSheetWithDefault = wb.Sheets(name)
End Function
Function sheetExists(name As String, Optional wb As Excel.Workbook) As Boolean
Dim sheet As Excel.Worksheet
If wb Is Nothing Then
Set wb = ThisWorkbook
End If
sheetExists = False
For Each sheet In wb.Worksheets
If sheet.name = name Then
sheetExists = True
Exit Function
End If
Next sheet
End Function
To use it in your code:
Sub Consolidate_Sheets()
Dim MyCell As Range
Dim MyRange As Range
Dim ws As Worksheet
Set MyRange = Sheets("Install_Input").Range("A2")
Set MyRange = Range(MyRange, MyRange.End(xlDown))
For Each MyCell In MyRange
If Sheets(Sheets.Count).Name <> MyCell.Value Then
'On Error Resume Next
set ws = getSheetWithDefault(MyCell.Value)
'On Error GoTo 0
End If
Next MyCell
End Sub
You could implement a CheckSheet function like the one described in this SO answer that loops through all existing sheets and compares the name of each sheet with the passed-in value.
HI I have created a VBA that takes info from a ALL data sheet and plots it in worksheets.
The worksheets get automatically generated which is great but the issue is that VBA is only supposed to create Unique worksheets - however this is not the case.
Example: if in my ALL data sheet I have IKEA 3 times then the first time the vba encounters IKEA then it should create a worksheet while it should ignore any repeats.
Actual
IKEA; Sheet 2 ; Sheet 3
Wanted
IKEA
VBA Code
Sub CreateSheetsFromAList()
Dim iReply As Integer
Dim MyCell As Range, MyRange As Range
On Error Resume Next
Range("B1").End(xlUp).AdvancedFilter _
Action:=xlFilterCopy, CopyToRange:=rListPaste.Cells(1, 1), Unique:=True
Set MyRange = Sheets("ALL").Range("B1")
Set MyRange = Range(MyRange, MyRange.End(xlDown))
For Each MyCell In MyRange
Sheets.Add After:=Sheets(Sheets.Count) 'creates a new worksheet
Sheets(Sheets.Count).Name = MyCell.Value ' renames the new worksheet
Next MyCell
End Sub
Try this code (it creates new sheet only if there is no sheets with name MyCell.Value):
Sub CreateSheetsFromAList()
Dim iReply As Integer
Dim MyCell As Range, MyRange As Range
Dim sh as Worksheet
On Error Resume Next
Range("B1").End(xlUp).AdvancedFilter _
Action:=xlFilterCopy, CopyToRange:=rListPaste.Cells(1, 1), Unique:=True
Set MyRange = Sheets("ALL").Range("B1")
Set MyRange = Range(MyRange, MyRange.End(xlDown))
For Each MyCell In MyRange
Set sh = Nothing
Set sh=Sheets(MyCell.Value)
If sh is Nothing Then
Sheets.Add After:=Sheets(Sheets.Count) 'creates a new worksheet
Sheets(Sheets.Count).Name = MyCell.Value ' renames the new worksheet
End If
Next MyCell
End Sub
I am working on the file where:
First, from a given list created a number of sheets with the names on the list (accounts)
Second, from the destination "Master" sheet, all the content should be copied to each of the new sheets
While I succeeded in creating a list of new sheets (thanks to this website), I am stuck with the content of each sheet. Do not know how to fill in each new sheet with identical content which is located in the sheet "Master". The sheet "Master" has certain format, formulas, and buttons so I need to make sure that each new sheet has exctly the same layout and content. Any suggestions how to incorporate it into below macro?
Sub CreateSheetsFromAList()
Application.ScreenUpdating = False
On Error GoTo ErrorHandler
Dim MyCell As Range, MyRange As Range
Set MyRange = Sheets("Cost Center").Range("A2")
Set MyRange = Range(MyRange, MyRange.End(xlDown))
For Each MyCell In MyRange
Sheets.Add After:=Sheets(Sheets.Count) 'creates a new worksheet
Sheets(Sheets.Count).Name = MyCell.Value ' renames the new worksheet
Next MyCell
Sheets("Instruction").Select
Range("A1").Select
ErrorHandler:
Sheets("Instruction").Select
Range("A1").Select
Exit Sub
Application.ScreenUpdating = True
End Sub
Your code is pretty close! To copy the contents of the "Master" sheet, replace
Sheets.Add After:=Sheets(Sheets.Count)
with
Sheets("Master").Copy After:=Sheets(Sheets.Count)
Trust this helps.
If the answer to my comment is yes, then you can try this:
Dim ws, new_ws as WorkSheet 'declare the worksheet
Set ws = Thisworkbook.Sheets("MasterSheet") 'set as mastersheet
For Each MyCell In MyRange
Set new_ws = ws.copy Before:=Thisworkbook.Sheets(1) 'creates a new worksheet
new_ws.Name = MyCell.Value 'rename it based on list
Next MyCell
Hope this helps.
I want to create worksheets from a list of "projects" from a master worksheet. When a worksheet is created I want it to be renamed as the project number from the list.
I found two macros that do the job but I need them to work together.
This one creates tabs and renames them.
Sub CreateSheetsFromAList()
Dim MyCell As Range, MyRange As Range
Set MyRange = Sheets("Invoice Summary").Range("B11")
Set MyRange = Range(MyRange, MyRange.End(xlDown))
For Each MyCell In MyRange
Sheets.Add After:=Sheets(Sheets.Count) 'creates a new worksheet
Sheets(Sheets.Count).Name = MyCell.Value ' renames the new worksheet
Next MyCell
End Sub
This one copies master tab and creates another worksheet.
Sub Test()
Dim ws1 As Worksheet
Set ws1 = ThisWorkbook.Worksheets("Master")
ws1.Copy ThisWorkbook.Sheets(Sheets.Count)
End Sub
Assuming there is no worksheet named "Master (2)" in your workbook, this code should work:
Sub CreateSheetsFromAList()
Dim ws1 As Worksheet
Set ws1 = ThisWorkbook.Worksheets("Master")
Dim MyCell As Range, MyRange As Range
Set MyRange = Sheets("Invoice Summary").Range("B11")
Set MyRange = Range(MyRange, MyRange.End(xlDown))
For Each MyCell In MyRange
ws1.Copy ThisWorkbook.Sheets(Sheets.Count)
ThisWorkbook.Worksheets("Master (2)").Name = MyCell.Value
Next MyCell
End Sub
It does seem odd that there is no worksheet object returned from the Worksheet.Copy method.
One thing to note when using xlDown to get the end range -- if you have zero cells or one cell in your range, xlDown will extend all the way to the last row of the worksheet, which will produce undesirable behavior. In this case, you'll get an error when attempting to rename the target sheet, but it is something to look out for.