Create new workbook with named tabs - excel

Ok what i want to do is make a macro that makes a new workbook with 5 tabs from a list in my excel.
I got the new workbook part, I got the (named) tabs part, but i'm stuck at the combination due to lack of knowledge.
Sub CreateForm()
Workbooks.Add
Dim xRg As Excel.Range
Dim wSh As Excel.Worksheet
Dim wBk As Excel.Workbook
Set wSh = ActiveSheet
Set wBk = ActiveWorkbook
Application.ScreenUpdating = False
For Each xRg In wSh.Range("I6:I12")
With wBk
.Sheets.Add After:=.Sheets(.Sheets.Count)
On Error Resume Next
ActiveSheet.Name = xRg.Value
If Err.Number = 1004 Then
Debug.Print xRg.Value & " already used as a sheet name"
End If
On Error GoTo 0
End With
Next xRg
End Sub
It almost works, it makes a new workbook with extra tabs, but it is one too many(due to with creation it having one already), and they are not named.
Bonus Question: It would be awesome if I also could copy a tab(named "Results") from this workbook to the end of the new workbook, but this is just extra.

You can use this code.
I read the new worksheet names to an array.
The number of sheets in a new workbook can vary - as the user can configure this. Therefore I first delete all sheets except of the first one, then add then new sheets - and in the end delete the first one (which is left from the first deletion round)
Sub createNewWorkbookWithSheets()
Dim arrNewNames As Variant
arrNewNames = Application.Transpose(ActiveSheet.Range("I6:I12").Value)
Dim wbNew As Workbook
Set wbNew = Application.Workbooks.Add
Dim i As Long, ws As Worksheet
With wbNew
'delete all but the first worksheet - one has to be left
Application.DisplayAlerts = False
For i = 2 To .Worksheets.Count
.Worksheets(i).Delete
Next
Application.DisplayAlerts = True
'add new worksheet
For i = LBound(arrNewNames) To UBound(arrNewNames)
Set ws = .Worksheets.Add(, .Worksheets(.Worksheets.Count))
ws.Name = arrNewNames(i)
Next
'delete first ws
Application.DisplayAlerts = False
.Worksheets(1).Delete ' the left one from the first deletion round
Application.DisplayAlerts = True
End With
'copy result sheet from this workbook
Set ws = ThisWorkbook.Worksheets("Result")
ws.Copy , wbNew.Worksheets(wbNew.Worksheets.Count)
End Sub

You are adding a workbook, once that workbook has been created it becomes the active workbook.
If you want to use activeworkbook and activesheet to set the sheet name range, you could to do this before adding the new workbook.
Once you have run the code, you can delete the first sheet.
I think in this sample, you don't need activeworkbook because you are using activesheet
BTW I6:I12 would be 7 items not 5.
It need to be in chronological order.
Something like this.
Sub CreateForm()
Dim xRg As Range,rng as range
Dim wSh As Worksheet
Dim wBk As Workbook,bk as workbook
Set wBk = ActiveWorkbook
Set wSh = ActiveSheet
Set rng= wsh.range("I6:I12")
set bk = workbooks.add
For Each xRg In rng
With bk
.Sheets.Add After:=.Sheets(.Sheets.Count)
On Error Resume Next
ActiveSheet.Name = xRg.Value
If Err.Number = 1004 Then
Debug.Print xRg.Value & " already used as a sheet name"
End If
On Error GoTo 0
End With
Next xRg
End Sub

(a) wSh is set to the active sheet of the new created workbook and that is empty, therefore xRg.Value is always empty. This explains why your sheets are not renamed. Set it to the sheet holding the sheet names, eg
Set wSh = ThisWorkbook.Sheets(1)
(b) When you create a new Workbook, you will have (depending on your Excel settings) at least 1 worksheet. In your loop, you create a new sheet for every iteration, leaving the original sheets untouched. This explains why you have one sheet more than you expect.
Dim newSheetCount As Long
For Each xRg In wSh.Range("I6:I12")
With wBk
newSheetCount = newSheetCount + 1
' Add a new sheet if needed.
if .Sheets.Count < newSheetCount Then .Sheets.Add After:=.Sheets(.Sheets.Count)
On Error Resume Next
ActiveSheet.Name = xRg.Value
If Err.Number = 1004 Then
Debug.Print xRg.Value & " already used as a sheet name"
End If
On Error GoTo 0
End With
Next xRg
(c) Copying a sheet is easy, just use the Worksheet.Copy method:
ThisWorkbork.Sheets("Result").Copy After:=.Sheets(.Sheets.Count)

Related

Iterating through multiple ranges to create a new sheet and update data

I'm trying to create a new sheet labeled with a different identifier from a range and also have two cells from other ranges included on each update. I can get the new sheets to create with a different label from a range, and have the first cell in the second range (xRg2) added to each subsequent sheet, but haven't been successful at iterating through the second range. I know I need another loop somewhere but my last nest created way too many sheet. See example below
Sub Add()
Dim xRg As Excel.Range
Dim xRg2 As Excel.Range
Dim wSh As Excel.Worksheet
Dim wBk As Excel.Workbook
Dim wSh2 As Excel.Worksheet
Dim wSh3 As Excel.Worksheet
Set wSh = ActiveSheet
Set wBk = ActiveWorkbook
Set wSh2 = ThisWorkbook.Sheets("List")
Set wSh3 = ThisWorkbook.Sheets("Template")
Set xRg2 = wSh2.Range("G66:G88")
Application.ScreenUpdating = False
For Each xRg In wSh2.Range("B66:B88")
With wBk
wSh3.Copy after:=.Sheets(.Sheets.Count)
On Error Resume Next
wSh.Name = xRg.Value
wSh.Cells(33,7) = xRg2.Value
If Err.Number = 1004 Then
Debug.Print xRg.Value & "already used as a sheet name"
End If
On Error GoTo 0
End With
Next xRg
Application.ScreenUpdating = True End Sub
So, to summarize, the goal here is to input the ranges into the code each time and have each new sheet include the first values from each range, then the second sheet the second values from each range, and so on until the xRg is at the end of it's list. I know there's only two ranges down here but the total will be 3. Also apologies on the poor variable discipline...
Thanks!
Try something like this (sorry do not like all those x... variable names)
Sub Add()
Dim c As Range
Dim wb As Workbook, ws As Worksheet, wsList As Worksheet
Set wb = ActiveWorkbook
Set wsList = wb.Worksheets("List")
Application.ScreenUpdating = False
For Each c In wsList.Range("B66:B88").Cells
ThisWorkbook.Sheets("Template").Copy after:=wb.Sheets(wb.Sheets.Count)
Set ws = wb.Sheets(wb.Sheets.Count) '<< get the just-created sheet copy
On Error Resume Next
ws.Name = c.Value
ws.Cells(33, 7) = c.EntireRow.Columns("G").Value
If Err.Number = 1004 Then
Debug.Print "'" & c.Value & "' already used as a sheet name"
End If
On Error GoTo 0
Next c
Application.ScreenUpdating = True
End Sub

Combine sheets from different workbooks with same name

I'm trying to solve an issue i'm currently dealing with.
Below you'll find the issue:
I'm having multiple excel sheets that I'd like to merge into one file (located into different workbooks).
Each workbook consists out of the same sheets (SHEET1, SHEET2, SHEET3).
I'd like to merge all workbooks into 1 masterfile - and want to keep the same structure (SHEET1 = all date form all sheets).
So far I've manged to solve the merging issue with the below code:
Sub mergeFiles()
Dim numberOfFilesChosen, i As Integer
Dim tempFileDialog As FileDialog
Dim mainWorkbook, sourceWorkbook As Workbook
Dim tempWorkSheet As Worksheet
Set mainWorkbook = Application.ActiveWorkbook
Set tempFileDialog = Application.FileDialog(msoFileDialogFilePicker)
tempFileDialog.AllowMultiSelect = True
numberOfFilesChosen = tempFileDialog.Show
For i = 1 To tempFileDialog.SelectedItems.Count
Workbooks.Open tempFileDialog.SelectedItems(i)
Set sourceWorkbook = ActiveWorkbook
For Each tempWorkSheet In sourceWorkbook.Worksheets
tempWorkSheet.Copy after:=mainWorkbook.Sheets(mainWorkbook.Worksheets.Count)
Next tempWorkSheet
sourceWorkbook.Close
Next i
End Sub
I navigate via de Application.FileDialog to the folder with the different sheets. I select the files i want to merge, and then VBA does its job, and merges the files into one Excel sheet.
Hence some of the sheets are having the same name (=always) = SHEET 1, SHEET 2, SHEET 3, the merged sheets are having the same name with a figure behind (= SHEET1 (1), SHEET1 (2) ...)
I've managed to merge all the sheets into one worksheet, using the below code - but i can't mange to add a restriction to it - e.g. merge all the sheets starting with (SHEET1* into MASTERDATA SHEET1, SHEET2 * into MASTERDATA SHEET2, SHEET3 * into MASTERDATA SHEET3)
Sub Merge_Sheets()
Sheets.Add
ActiveSheet.Name = "MASTERDATA"
For Each ws In Worksheets
ws.Activate
If ws.Name <> "MASTERDATA" Then
ws.UsedRange.Select
Selection.Copy
Sheets("MASTERDATA").Activate
ActiveSheet.Range("A1048576").Select
Selection.End(xlUp).Select
If ActiveCell.Address <> "$A$1" Then
ActiveCell.Offset(1, 0).Select
End If
ActiveSheet.Paste
End If
Next
End Sub
Could any of you help me out + explain briefly the next step?
Kind Regards
D
You should check if the sheet name already exists in mainWorkbook. If it does append that data to the end of that sheet rather than insert a new worksheet. Therefore, you do not need to the second code
Try this (not tested and you might need to debug it, also note comments starting with '*)
Sub mergeFiles()
'* declare the type for each variable (no just at the end of the line)
'* always use Long if you're tempted to use Integer
Dim numberOfFilesChosen As Long, i As Long
Dim tempFileDialog As FileDialog
Dim mainWorkbook As Workbook, sourceWorkbook As Workbook
Dim tempWorkSheet As Worksheet
'* declare the destination sheet
Dim destWorkSheet As Worksheet
Set mainWorkbook = ThisWorkbook ' Application.ActiveWorkbook
Set tempFileDialog = Application.FileDialog(msoFileDialogFilePicker)
tempFileDialog.AllowMultiSelect = True
numberOfFilesChosen = tempFileDialog.Show
For i = 1 To tempFileDialog.SelectedItems.Count
'* you can set sourceWorkbook directly here
Set sourceWorkbook = Workbooks.Open(tempFileDialog.SelectedItems(i))
'Set sourceWorkbook = ActiveWorkbook
On Error Resume Next
For Each tempWorkSheet In sourceWorkbook.Worksheets
Set destWorkSheet = mainWorkbook.Sheets(tempWorkSheet.Name)
If Err.Number > 0 Then '* worksheet doesn't exist in mainWorkbook
tempWorkSheet.Copy after:=mainWorkbook.Sheets(mainWorkbook.Worksheets.Count)
Err.Clear
Else '* worksheet already exists
With tempWorkSheet.UsedRange
.Copy Destination:=destWorkSheet.Cells(Rows.Count, 1).End(xlUp).Offset(1)
'* If you only want to copy the values remove the above line and uncomment the below line
'destWorkSheet.Cells(Rows.Count, 1).End(xlUp).Offset(1).Resize(.Rows.Count, .Columns.Count).Value = .Value
End With
End If
Next tempWorkSheet
On Error GoTo 0
sourceWorkbook.Close
Next i
End Sub

Copy two worksheets into different workbook replacing current data

I modified code from Copy worksheet into different workbook replacing current data.
If I deselect range or I have selected different cell than A1, code falls into 1004 error.
Sub TG_update()
Dim wb1 As Workbook, wb2 As Workbook, ws1Format As Worksheet, ws2Format As Worksheet, ws3Format As Worksheet, ws4Format As Worksheet
Application.DisplayAlerts = False
Application.ScreenUpdating = False
Set wb1 = ThisWorkbook
Set wb2 = Workbooks.Open("[add your path.xlsx]")
Set ws1Format = wb1.Sheets("SheetA1")
Set ws2Format = wb2.Sheets("SheetB1")
Set ws3Format = wb1.Sheets("SheetA2")
Set ws4Format = wb2.Sheets("SheetB2")
'' Copy the cells of the "Format" worksheet.
ws2Format.Cells.Copy
'' Paste cells to the sheet "Format".
wb1.Sheets("SheetA1").Paste
ws4Format.Cells.Copy
wb1.Sheets("SheetB1").Paste
wb2.Close False 'remove false if you want to be asked if the workbook shall be saved.
wb1.Sheets("Store").Activate
Application.ScreenUpdating = True
Application.DisplayAlerts = True
MsgBox "Date successfully updated"
End Sub
Please try this code. Instead of copying and pasting millions of blank cells this code copies the worksheet from the source and pastes it to the workbook with the code. If the action is successful the old sheet is deleted. The final report alerts about errors if sheets weren't found.
Sub TG_update()
' 016
Dim Wb As Workbook ' ThisWorkbook
Dim WbS As Workbook ' Source
Dim Ffn As String ' Full FileName
Dim Ws As Worksheet
Dim TabName() As String
Dim i As Integer ' TabName index
Dim n As Integer ' tab counter
Set Wb = ThisWorkbook
' specify the workbook to be copied from: Full path and name
Ffn = "F:\AWK PC\Drive E (Archive)\PVT Archive\Class 1\1-2018 (Jan 2020)\TXL 180719 Z Distance.xlsm"
' enumerate the sheet names in CSV format (sheets must exist in Wb)
TabName = Split("SheetA1,SheetB1", ",")
With Application
.ScreenUpdating = False
.DisplayAlerts = False
End With
Set WbS = Workbooks.Open(Ffn)
For i = 0 To UBound(TabName)
On Error Resume Next ' suppress error if worksheet isn't found
WbS.Worksheets(TabName(i)).Copy After:=Wb.Worksheets(Wb.Worksheets.Count)
If Err.Number = 0 Then
n = n + 1
End If
Next i
WbS.Close SaveChanges:=False
On Error GoTo 0
For i = 0 To UBound(TabName)
For Each Ws In Wb.Worksheets
If InStr(Ws.Name, TabName(i) & " (") = 1 Then
Wb.Worksheets(TabName(i)).Delete
Ws.Name = TabName(i)
End If
Next Ws
Next i
With Application
.ScreenUpdating = True
.DisplayAlerts = True
End With
MsgBox n & " of " & i & " worksheets were successfully updated.", _
vbInformation, "Action report"
End Sub
Creative names like Wb1, Wb2, Ws1, Ws2, SheetA1, SheetA2 represent the punishment imaginative programmers inflict on those who come after them to correct their hastily concocted code. Give your VBA project a better reputation by bestowing names on your two worksheets that permit their identification.

VBA code needed to duplicate and rename a sheet (Sheet 1) based on cell names in a range on Sheet 2

In this workbook, I have 2 worksheets- (CAM) & (DIST)
On (CAM) is a table titled "Distributor". If I enter a name into this table, I want the (DIST) tab to duplicate and be renamed to what I just entered in the "Distributor" table on sheet 1.
This is code I tried using but..... im not good at this and don't understand very well.
Sub AddSheets()
Dim xRg As Excel.Range
Dim wSh As Excel.Worksheet
Dim wBk As Excel.Workbook
Set wSh = ActiveSheet
Set wBk = ActiveWorkbook
Application.ScreenUpdating = False
For Each xRg In wSh.Range("A1:A7")
With wBk
.Sheets.Add after:=.Sheets(.Sheets.Count)
On Error Resume Next
ActiveSheet.Name = xRg.Value
If Err.Number = 1004 Then
Debug.Print xRg.Value & " already used as a sheet name"
End If
On Error GoTo 0
End With
Next xRg
Application.ScreenUpdating = True
End Sub
Your program may work as follows:
1. For each entry in cam, check if a coresponding worksheet exists
2. if not, then create the worksheet by duplicating the dist worksheet:
Dim wBk As Workbook
Dim wSh as Worksheet, wNw as Worksheet
Dim xRg as Range
Set wBk = ActiveWorkbook
Set wSh = wBk.Workhseets("CAM")
Set xRg = wSh.Range("B2") ' Assuming your table "CAM" starts in cell B2
while not xRg.Value = ""
on error resume next
set wSh = wBk.Worksheets(xRg.Value) ' --- Try accessing worksheet
on error goto 0 ' --- Remove error handler
if wSh is nothing then ' --- no worksheet
set sSh = wBk.Worksheets("Dist") ' --- Source worksheet
set sNw = wBk.Worksheets.Add() ' --- New worksheet as target
sSh.UsedRange.Copy ' --- Copy all from source
sNw.Range("A1").PasteSpecial xlPasteAll
end if
wend
Good luck!

Copy two sheets into new workbook as values, then save with todays date and close workbook

When using all the different examples that I've found on stackoverflow they give me a complex task that still requires a mouse click to confirm its ok to paste the data. I also am struggling to get the whole thing to operate in one section of VBA code.
Public Sub copySheets()
Dim wkb As Excel.Workbook
Dim newWkb As Excel.Workbook
Dim wks As Excel.Worksheet
Dim newWks As Excel.Worksheet
Dim sheets As Variant
Dim varName As Variant
'------------------------------------------------------------
'Define the names of worksheets to be copied.
sheets = VBA.Array("Analysis - London", "London - Commercial")
'Create reference to the current Excel workbook and to the destination workbook.
Set wkb = Excel.ThisWorkbook
Set newWkb = Excel.Workbooks.Add
For Each varName In sheets
'Clear reference to the [wks] variable.
Set wks = Nothing
'Check if there is a worksheet with such name.
On Error Resume Next
Set wks = wkb.Worksheets(VBA.CStr(varName))
On Error GoTo 0
'If worksheet with such name is not found, those instructions are skipped.
If Not wks Is Nothing Then
'Copy this worksheet to a new workbook.
Call wks.Copy(newWkb.Worksheets(1))
'Get the reference to the copy of this worksheet and paste
'all its content as values.
Set newWks = newWkb.Worksheets(wks.Name)
With newWks
Call .Cells.Copy
Call .Range("A1").PasteSpecial(Paste:=xlValues)
End With
End If
Next
ActiveWorkbook.SaveCopyAs Filename:=("C:\Users\\My stuff\Forecast" & Format(Now(), "YYYYMMDD") & " Forecasting" & ".xlsm")
Thanks
Replace
With newWks
Call .Cells.Copy
Call .Range("A1").PasteSpecial(Paste:=xlValues)
End With
With
Dim c as range
For each c in newwks.usedrange
c.formula = c.value
next c

Resources