In my code, I select items from my workbook and create a new workbook to paste the selected items within. I then call another sub (Callothers) using an argument to pass along this new workbook such that the remaining code runs in the new workbook. However, rather than run in the new workbook, the rest of the code occurs in the original.
I have messed with the argument, however I am not reaching a solution.
Sub occurences()
'sort
Set oldbook = ActiveWorkbook
lRow = Cells(Rows.Count, 42).End(xlUp).Row 'Finds the last used row
Dim coll As New Collection 'Collections are similar to arrays, but you don't need to declare a size
For Row = 2 To lRow 'Loop through each row
newitem = Sheets("Sheet1").Cells(Row, 42) 'Grab the contents of the row
flag = False 'flag will be false unless we find a match in our collection
For Each Item In coll 'loop through our collection
If Item = newitem Then 'check for a match
flag = True 'if there is a match, set flag
End If
Next Item
If flag = False Then 'if a match wasn't found,
coll.Add newitem 'add the new item to the collection
End If
Next Row 'now go to the next row and start again
MsgBox (coll.Count) 'this tells us how many items are in the collection
For Each Item In coll 'this displays each item in the collection
Set newbook = Workbooks.Add
MsgBox ("oldbook a2 = " & oldbook.Sheets("Sheet1").Range("A2"))
With newbook
Row = 1
oldbook.Sheets("Sheet1").Range("a1:ar1").Copy .Sheets("Sheet1").Rows(Str(Row))
nRow = 2
For Row = 2 To lRow
If oldbook.Sheets("Sheet1").Cells(Row, 42) = Item Then
oldbook.Sheets("Sheet1").Rows(Str(Row)).Copy .Sheets("Sheet1").Rows(Str(nRow))
nRow = nRow + 1
End If
Next Row
fname = Replace(Item, " ", "-")
fname = fname & ".xlsx"
MsgBox ("about to call")
Call CallOthers(newbook)
.SaveAs Filename:=fname '("C:\Users\Joshua.Elphee\Desktop\TEST Save\" & fname)
.Close
End With
Next Item
End Sub
Sub CallOthers(newbook)
Call Delete_Rows_Based_On_Value(newbook)
Call Delete_Rows_Based_On_Value1(newbook)
End Sub
No error message, just performs the actions within the wrong workbook
You need put more info, but if idea is: You have 2 workbooks OLDBook and NEWBook , you extract info from OLDBook and put in NEWBook then use "Call Sub OTHER()" and you problem is that instead delete rows in NEWBook delete rows in OLDBook . For you, problem is in your code OTHER but you dont put here (maybe is top secret XD) so you need are explicit sentences like OLDBook.Sheets(1) and NEWBook.close then be sure active workbook you are using like OLDBook.active because when you use .ADD you create a variable as workbooks (collection) that have 2 elements workbook OLDBook and workbook OLDBook ; however if you dont like use this way you also can use public variables on top your module put
Public OLDBook as workbook
Public OLDBook as workbook
so only you need to use inside your sub()
Set OLDBook = ActiveWorkbook
Set NEWBook = new Workbooks
or if you have path
OLDBook.open "C:\T\"
NEWBook = new Workbook
NEWBook.open
Related
I have a Word file with approximately 10 pages and 20 tables. Some of these tables have checkboxes. I want to copy these tables into an Excel file.
The following code copies all tables from my Word file into my Excel file:
Sub Import()
Option Explicit
Dim wb As Workbook
Dim sh As Worksheet
Dim sheet As Worksheet
Dim lzeile As Integer
Set wb = ActiveWorkbook
Set sh = wb.ActiveSheet
Set sheet = wb.Worksheets("Tabelle1")
Dim Btxt As Object
Set Btxt = CreateObject("Word.Application")
Btxt.Visible = True
Btxt.documents.Open "C:\Users\*.doc" '*=path
lzeile = 0
For i = 1 To 20
Btxt.ActiveDocument.Tables(i).Range.Copy
Application.Goto sheet.Cells(1 + lzeile, 1)
sheet.PasteSpecial Format:="HTML", Link:=False, DisplayAsIcon:=False
lzeile = sheet.Cells(Rows.Count, 1).End(xlUp).Row
lzeile = lzeile + 1
sheet.Cells(lzeile, 1) = "Tabelle" & i
Next i
Btxt.Quit
Set Btxt = Nothing
Set wb = Nothing
Set sh = Nothing
End Sub
It does not copy checkboxes or the value (0 = not checked / 1 = checked) of the checkbox.
I can write the value of a checkbox into a cell in my excel sheet with this line:
sheet.Cells(j, 10) = Btxt.ActiveDocument.Tables(i).FormFields.Item("Kontrollkästchen" & j).Result
With a loop j over all "Kontrollkästchen" (german translation of contentcontrol or formfield item) so basically the name of all formfield items in this Word file.
How can I get the position of these formfield items or identify which formfield item / ContentControl is in which table?
I tried to go through all rows and columns in each table because none of them are larger than 10x10. But I can´t find a way to check if a checkbox is maybe in table 3 on column 5 row 5 and then read the name of this checkbox to a safe the value (0 / 1) in the Excel cell on the same position in my copied table.
The solution depends on whether they're formfields or content controls.
Assuming they're formfields:
Sub Demo()
Dim i As Long, j As Long, Rng As Range
With ActiveDocument
For i = .FormFields.Count To 1 Step -1
With .FormFields(i)
If .Type = wdFieldFormCheckBox Then
j = Abs(.CheckBox.Value)
Set Rng = .Range
.Delete
Rng.Text = j
End If
End With
Next
End With
End Sub
Assuming they're content controls:
Sub Demo()
Dim i As Long, j As Long, Rng As Range
With ActiveDocument
For i = .ContentControls.Count To 1 Step -1
With .ContentControls(i)
If .Type = wdContentControlCheckBox Then
j = Abs(.Checked)
Set Rng = .Range
.Delete
Rng.Text = j
End If
End With
Next
End With
End Sub
For the sake of simplicity and clarity, the sample code below leaves out the parts having to do with Excel, as well as creating the instance of the Word Application. It shows only how to access the Word document's checkboxes and convert those to static values.
At the end, also, the document is closed without saving changes, which means forms protection and the checkboxes should be left intact - the macro will not have affected them.
Note: You should have Option Explicit at the top of the code page, not inside a "Sub".
How it works
The document to be processed is opened and at that moment set to an object (doc). Use this instead of ActiveDocument as it will be much clearer and, in case the user would try to do something, won't affect macro execution.
If the document has forms protection, this must be turned off in order to delete the checkboxes and insert static values.
Then all the form fields are looped. If they are checkboxes, the value is determined, the checkbox removed and the value assigned to the range the checkbox occupied.
After this has completed comes the code to transfer data to Excel. Then the document is closed without saving changes.
Sub ConvertCheckBoxesToValues()
Dim ff As Object ' Word.FormField
Dim doc As Object ' Word.Document
Dim cbValue As String
Dim rngFF As Object ' Word.Range
Set doc = Btxt.Documents.Open("C:\Users\*.doc") '*=path
If doc.ProtectionType <> -1 Then 'wdNoProtection
doc.Unprotect
End If
For Each ff In doc.FormFields
If ff.Type = 71 Then 'wdFieldFormCheckBox
If ff.CheckBox.value = True Then
cbValue = "1"
Else
cbValue = "0"
End If
Set rngFF = ff.Range
ff.Delete
rngFF = cbValue
End If
Next
'Transfer the information to Excel, then
doc.Close 0 'wdDoNotSaveChanges
End Sub
I have a list of files with the same structure and I want to extract some information from columns A, B, and C and print it to another workbook.
I found a way to do it for a single file, but now I don't understand how can I do it using the list of given files. I tried using collections, but it doesn't work.
Here's what I came up with:
Sub Pulsante1_Click()
Dim FileGeStar As Variant
Dim myCol As Collection
Set myCol = New Collection
myCol.Add "C:\Users\xxx\Desktop\articoli_def.xlsx"
myCol.Add "C:\Users\xxx\Desktop\pippo\SS20_def_ENG.xlsx"
For Each FileGeStar In myCol
Workbooks.Open Filename:=FileGeStar
FileGeStar = Application.ActiveWorkbook.Name
Dim Code As String
Dim Description As String
Dim FilePath As String
Dim i As Long
i = 2
While Range("A" & i) <> ""
FilePath = Application.ActiveWorkbook.Path
Code = Trim(Range("A" & i).Value)
Description = Trim(Range("B" & i).Value)
Workbooks("Report.xlsm").Worksheets(1).Range("A" & i).Value = FilePath
Workbooks("Report.xlsm").Worksheets(1).Range("B" & i).Value = Code
Workbooks("Report.xlsm").Worksheets(1).Range("C" & i).Value = Description
i = i + 1
Wend
Next FileGeStar
End Sub
What can I do?
This might look like an overkill, but I hope the code and comment's are self explanatory:
Option Explicit
Sub Pulsante1_Click()
Dim DestinationWorkbook As Workbook
Set DestinationWorkbook = ThisWorkbook 'I think report.xlsm is the workbook running the code
'if report.xlsm is not the workbook running the code then change thisworkbook for workbooks("Report.xlsm")
'add as many paths as you need to, another way would be to write them in a sheet and loop through to fill the array
Dim MyPaths As Variant
MyPaths = Array("C:\Users\xxx\Desktop\articoli_def.xlsx", "C:\Users\xxx\Desktop\pippo\SS20_def_ENG.xlsx")
'Declare a workbook variable for the source workbooks
Dim SourceWorkbook As Workbook
'Declare a long variable to loop through your path's array
Dim i As Long
'loop through the start to the end of your array (will increase as the array does)
For i = LBound(MyPaths) To UBound(MyPaths)
Set SourceWorkbook = OpenWorkbook(MyPaths(i)) 'this will set the workbook variable and open it
CopyData SourceWorkbook, DestinationWorkbook 'this will copy the data to your destination workbook
SourceWorkbook.Close , False
Set SourceWorkbook = Nothing
Next i
End Sub
Private Function OpenWorkbook(FullPath As String) As Workbook
Set OpenWorkbook = Workbooks.Open(FullPath, False, True)
End Function
Private Sub CopyData(wbO As Workbook, wbD As Workbook)
'this procedure calculates the last row of your source workbook and loops through all it's data
'later calls the AddDataToMasterWorkbook procedure to paste the data
With wbO.Sheets(1) 'Im assuming your source workbook has the data on sheet1
Dim LastRow As Long
LastRow = .Cells(Rows.Count, "A").End(xlUp).Row
Dim FilePath As String
FilePath = wbO.Path
Dim Code As String
Dim Description As String
Dim C As Range
For Each C In .Range("A2:A" & LastRow) 'this will loop from A2 to the last row with data
Code = Trim(C)
Description = Trim(C.Offset(, 1))
AddDataToMasterWorkbook wbD, FilePath, Code, Description
Next C
End With
End Sub
Private Sub AddDataToMasterWorkbook(wb As Workbook, FilePath As String, Code As String, Description As String)
'This procedure calculates the last row without data and adds the items you need every time
With wb.Sheets(1)
Dim LastRow As Long
LastRow = .Cells(Rows.Count, "A").End(xlUp).Row + 1
.Range("A" & LastRow) = FilePath
.Range("B" & LastRow) = Code
.Range("C" & LastRow) = Description
End With
End Sub
To loop though files, you can indeed use a collection, or an array, you can also loop through all files in directory with certain extension, or partial file name. Check out DIR function.
Best not to use ActiveWorkbook, better approach would be to set a workbook object like so: Set wb = Workbooks.Open(fullPathToYourWorkbook).
For what you're doing, there's no need to go row by row, much more efficient way would be to copy entire range, not only it's a lot quicker but also it's only 1 line of code; assuming your destination is ThisWorkbook.Sheets(1) and wb object is set: wb.Range("A:C").Copy Destination:=Thisworkbook.Sheets(1).Range("A:C"). If you need to edit copied data (trim or whatever) consider Range Replace method.
However, if you want to go row by row for whatever reason, as BigBen mentioned in the comment - get rid of While loop.
It's a good idea to set Application.ScreenUpdating to False when opening/closing workbooks, then back to True once it's all done. It will prevent user from accidentaly clicking something etc and will make it look like it's not opening any workbook.
Here's my approach (untested) assuming the workbook you want to copy data to is Workbooks("Report.xlsm").Worksheets(1):
Sub Pulsante1_Click()
'set workbook object for the destination workbook
set wb_dest = Workbooks("Report.xlsm").Worksheets(1)
'disable screen updating
Application.ScreenUpdating = False
For Each target_wb In Array("C:\Users\xxx\Desktop\articoli_def.xlsx", "C:\Users\xxx\Desktop\pippo\SS20_def_ENG.xlsx")
'set wb object and open workbook
Set wb = Workbooks.Open(target_wb)
'find last row in this workbooks in columns A:B (whichever is greater)
LastRow = wb.Range("A:B").Find(What:="*", After:=wb.Range("A1"), SearchDirection:=xlPrevious).row
'copy required data
wb.Range("A1:B" & LastRow).Copy Destination:=wb_dest.Range("B1:C" & LastRow)
'fill column A with path to the file
wb_dest.Range("A1:A" & LastRow).Value = wb.Path
'close workbook
wb.Close False
Next
'enable screen updating
Application.ScreenUpdating = True
End Sub
Obviously an array is not the best approach if you have loads of different files, collection would be a lot clearer to read and edit in the future, unless you want to create a dynamic array, but there's no need for that in my opinion. I didn't declare variables or write any error handling, it's a simple code just to point you in the right direction.
If you want to disable workbook events or/and alerts, you can set Application.DisplayAlerts and Application.EnableEvents to False temporarily.
I have a file (F) that contains several workbooks, each workbook has the same format. I do a conditional sum on each of the workbook under column conditions. I want to put the output within another workbook that contains one worksheet per workbook looped (contained within F).
I cannot find the good strategy to change the worksheet name in function of the looped workbook' name.
Set Output_tot_n = Workbooks("Final_Output").Sheet_name.Range("B7")
I got
Error 438 "Object doesn't support this property or method"
The whole code:
Sub Proceed_Data()
Dim FileSystemObj As Object
Dim FolderObj As Object
Dim fileobj As Object
Dim Sheet_name As Worksheet
Dim i, j, k As Integer
Dim wb As Workbook
Set FileSystemObj = CreateObject("Scripting.FileSystemObject")
Set FolderObj = FileSystemObj.GetFolder("C:\...\")
For Each fileobj In FolderObj.Files
Set wb = Workbooks.Open(fileobj.Path)
Set Output_tot_n = Workbooks("Final_Output").Sheet_name.Range("B7")
If wb.Name = "AAA_SEPT_2018" Then
Sheet_name = Worksheets("AAA")
End If
If wb.Name = "BBB_SEPT_2018" Then
Sheet_name = Worksheets("BBB")
End If
If wb.Name = "CCC_SEPT_2018" Then
Sheet_name = Worksheets("CCC")
End If
' conditional sum
With wb.Sheets("REPORT")
For i = 2 To .Cells(Rows.Count, 14).End(xlUp).Row
If .Cells(i, "O").Value = "sept" Then
k = .Cells(i, "M").Value
End If
j = j + k
k = 0
Next i
End With
Output_tot_n = j
j = 0
wb.Save
wb.Close
Next fileobj
End Sub
Workbooks is a collection (part of the actual Application-object). A collection in VBA can be accessed either by index number (index starts at 1) or by name. The name of an open Workbook is the name including the extension, in your case probably either Final_Output.xlsx or Final_Output.xlsm.
Sheets and Worksheets are collections within a Workbook, again accessed via index or name (the difference is that Worksheets contains "real" spreadsheets while Sheets may also contain other sheet types, eg charts).
So in your case, you want to access a Range of a specific sheet of a specific workbook. The workbook has a fixed name, while the sheet name is stored in a variable. You can write for example
dim sheetName as string, sheet as Worksheet, Output_tot_n as Range
sheetName = "AAA" ' (put your logic here)
set sheet = Workbooks("Final_Output.xlsm").Worksheets(Sheet_name)
set Output_tot_n = sheet.Range("B7")
or put all together (depending on your needs)
set Output_tot_n = Workbooks("Final_Output.xlsm").Worksheets(Sheet_name).Range("B7")
No it actually works. Thank you again for your answers.
the problem was just is important to put "AAA_SEPT_2018.xlsx"
I have a sheet that has names, SSNs and 4 columns filled with the following values: S, MB, B.
For said columns I wish to replace S with the number 4, MB with the number 3 and B with the number 2.
Sub replace()
Dim str1, str2, str3, filename, pathname As String
Dim i As Integer
str1 = "MB"
str2 = "B"
str3 = "S"
filename = "p"
pathname = ActiveWorkbook.Path
i = 1
Do While filename <> ""
Set wb = Workbooks.Open(pathname & filename + i)
DoWork wb
wb.Close SaveChanges:=True
filename = Dir()
Loop
End Sub
Sub DoWork(wb As Workbook)
With wb
End With
End Sub
In the function DoWork, how do I create a loop to replace each of the values?
I mostly agree with Michael--to learn the most, you should get started on your own, and come back with more specific questions. However, I am looking to reach 50 rep so I will pander to you. But do please try to go through the code and understand it.
Your name suggests you are a programmer, so the concepts we make use of should be familiar. I like to work from the inside out, so here goes:
here are my variables:
Dim sFileName As String
Dim sFilePath As String
Dim wbBook As Excel.Workbook
Dim i As Double
Dim wsSheet As Excel.Worksheet
Dim rRange As Range
Dim c As Range
Dim dReplace As Double
At the core, you'll want a select case statement to read each cell and decide what the new value should be. Then you will assign the new value to the cell:
Select Case c.value 'c being the cell we are currently examining
Case "S"
dReplace = 4
Case "M"
dReplace = 3
Case "B"
dReplace = 2
Case Else
'Assuming you should only encounter the above values,
'then anything else is an error
'.assert false will stop the code, or you can replace
'with more refined error handling
Debug.Assert False
End Select
c.value = dReplace
Around that you'll want a for each loop to define the current cell and iterate through all the cells in the range you specify for that particular worksheet:
set rRange = wsSheet.Range("C2:E5000") 'Customize to your range
for each c in rRange.Cells
'...
next
Next level up is the for next loop to iterate through all the worksheets in the current file:
For i = 1 To 30
If wbBook.Sheets(i).Name = "" Then
GoTo NextOne
End If
Set wsSheet = wbBook.Sheets(i)
'...
NextOne:
Next i
The if then statement at the top prevents an error if there are fewer than 30 worksheets in a workbook. If the number of sheets per file varies then this will be useful, if the number is fixed, just adjust the loop to stop and the right spot. Of course, this assumes your workbooks have information on multiple sheets. If not skip the loop altogether.
I'm sure many will criticize my use of goto, but since VBA loops lack a continue command, this is the workaround I employ.
Around that you'll want another iterator to loop through your multiple files. Assuming they are all in the same folder, you can use the Dir() function to grab the file names one-by-one. You give it the file path and (optionally) the file type, and it will return the first file name it finds that meets your cirteria. Run it again and it returns the second file name, etc. Assign that to a string variable, then use the file path plus the file name to open the workbook. Use a do loop to keep going until runs out of files:
sFilePath = "C:\Your File Path Here\"
sFileName = Dir(sFilePath & "*.xlsx")
Do Until sFileName = ""
Set wbBook = Workbooks.Open(sFilePath & sFileName)
'...
wbBook.Save
wbBook.Close
sFileName = Dir()
Loop
Now Put it all together:
Sub ReplaceLetterCodewithNumberCode()
Dim sFileName As String
Dim sFilePath As String
Dim wbBook As Excel.Workbook
Dim i As Double
Dim wsSheet As Excel.Worksheet
Dim rRange As Range
Dim c As Range
Dim dReplace As Double
Application.ScreenUpdating = False
sFilePath = "C:\Your File Path Here\"
sFileName = Dir(sFilePath & "*.xlsx")
Do Until sFileName = ""
Set wbBook = Workbooks.Open(sFilePath & sFileName)
For i = 1 To 30
If wbBook.Sheets(i).Name = "" Then
GoTo NextOne
End If
Set wsSheet = wbBook.Sheets(i)
Set rRange = wsSheet.Cells("C2:E5000") 'Customize to your range. Assumes the range will be the same
For Each c In rRange.Cells
Select Case c.value 'c being the cell we are currently examining
Case "S"
dReplace = 4
Case "M"
dReplace = 3
Case "B"
dReplace = 2
Case Else
'Assuming you should only encounter the above values,
'then anything else is an error
'.assert false will stop the code, or you can replace
'with more refined error handling
Debug.Assert False
End Select
c.value = dReplace
Next
NextOne:
Next i
wbBook.Save
wbBook.Close
sFileName = Dir()
Loop
'Clean up
Set wbBook = Nothing
Set wsSheet = Nothing
Set rRange = Nothing
Set c = Nothing
Application.ScreenUpdating = True
End Sub
I'll provide a high level explanation of this; implementation will be up to you. You'll start with a crawler to open all of these files one by one (a google search should help you with this).
I'm not exactly sure how your sheets are organized but the general idea is to open each sheet and perform the action, so you'll need a list of filenames/paths or do it sequentially. Then once inside the file assuming the structure is the same of each you'll grab the column and input the appropriate value then save and close the file.
If you're looking for how to open the VBA editor go to options and enable the Developer tab.
This is a good beginner project and while you may struggle you'll learn a lot in the process.
I'm new to VBA. I have found code that copy and rename multiple template worksheets based on a list in a column (A1, A2, A3 etc). I tried modifying it to loop through a row instead, ie cells A1, B1, C1, D1, E1, but no luck. I want to copy multiple templates and rename them based on an account number entered via a user input form. I have created a worksheet, LedgerArray, that lists worksheet names for each account number. Example:
row1: 1Savings, 1Shares, 1Statement
row2: 2Savings, 2Shares, 2Statement
Thanks in advance
Hello Ambie, your effort is much appreciated, fluey infant especially. I developed the code below. It works as far as copying and renaming the templates, and assigning user input to specific template header cells. These tasks are intended for new accounts. A separate user form is intended for existing accounts. As you indicated, no error handling procedures are included (eg entry of a duplicate account number). Also, the section of the code that should transfer share transaction data to the first empty row in the renamed worksheet does not work. When executed, the code returns no syntax error but the result on the first empty row is blank.
Sub CommandButton1_Click()
Dim Template As String, str1 As String, str2 As String, str3 As String, str4 As String, str5 As String
Dim ws As Worksheet, lrShar As Long, lrSav As Long, lrTD As Long, lrStmnt As Long
str1 = "Shares"
str2 = "Savings"
str3 = "TimeDeposit"
str4 = "Loans"
str5 = "Statements"
'hide the form
frmAddSheet.Hide
'Select 1st template
Template = "TemplateShares"
'copy template to create a new sheet
Sheets(Template).Select
Sheets(Template).Copy After:=Sheets(Sheets.Count)
'make the sheet visible in case the template is hidden
ActiveSheet.Visible = xlSheetVisible
'Rename the sheet
ActiveSheet.Name = AccNumTextBox & str1
'Transfer Heading data
Set ws = Sheets(AccNumTextBox & str1)
ws.Range("A4") = AccNumTextBox.Value
ws.Range("B5") = DTPicker4.Value
ws.Range("B6") = Reference.Value
ws.Range("B7") = RegFeeTextBox.Value
ws.Range("B8") = NameTextBox.Value
ws.Range("B9") = AddressTextBox.Value
ws.Range("B10") = TelNumTextBox.Value
ws.Range("B11") = EmailTextBox.Value
ws.Range("B12") = ComboBox2.Value
ws.Range("B13") = DOBDTPicker.Value
'transfer Share transaction data
lrShar = ws.Range("A" & Rows.Count).End(xlUp).Row + 1
ws.Range("A" & lrShar).Value = DTPicker4.Value
ws.Range("B" & lrShar).Value = Reference.Value
ws.Range("C" & lrShar).Value = SharesTextBox.Value
'Select 2nd template
Template = "TemplateSavings"
'copy template to create a new sheet
Sheets(Template).Select
Sheets(Template).Copy After:=Sheets(Sheets.Count)
'make the sheet visible in case the template is hidden
ActiveSheet.Visible = xlSheetVisible
'Rename the sheet
ActiveSheet.Name = AccNumTextBox & str2
'Transfer Heading data
Set ws = Worksheets(AccNumTextBox & str2)
ws.Range("A4") = AccNumTextBox.Value
ws.Range("B5") = DTPicker4.Value
ws.Range("B6") = Reference.Value
ws.Range("B7") = RegFeeTextBox.Value
ws.Range("B8") = NameTextBox.Value
ws.Range("B9") = AddressTextBox.Value
ws.Range("B10") = TelNumTextBox.Value
ws.Range("B11") = EmailTextBox.Value
ws.Range("B12") = ComboBox2.Value
ws.Range("B13") = DOBDTPicker.Value
'Select 3rd template
Template = "TemplateTimeDeposit"
'copy template to create a new sheet
Sheets(Template).Select
Sheets(Template).Copy After:=Sheets(Sheets.Count)
'make the sheet visible in case the template is hidden
ActiveSheet.Visible = xlSheetVisible
'Rename the sheet
ActiveSheet.Name = AccNumTextBox & str3
'Transfer Heading data
Set ws = Worksheets(AccNumTextBox & str3)
ws.Range("A4") = AccNumTextBox.Value
ws.Range("B5") = DTPicker4.Value
ws.Range("B6") = Reference.Value
ws.Range("B7") = RegFeeTextBox.Value
ws.Range("B8") = NameTextBox.Value
ws.Range("B9") = AddressTextBox.Value
ws.Range("B10") = TelNumTextBox.Value
ws.Range("B11") = EmailTextBox.Value
ws.Range("B12") = ComboBox2.Value
ws.Range("B13") = DOBDTPicker.Value
'Select 4th template
Template = "TemplateLoans"
'copy template to create a new sheet
Sheets(Template).Select
Sheets(Template).Copy After:=Sheets(Sheets.Count)
'make the sheet visible in case the template is hidden
ActiveSheet.Visible = xlSheetVisible
'Rename the sheet
ActiveSheet.Name = AccNumTextBox & str4
'Select 5th template
Template = "TemplateStatement"
'copy template to create a new sheet
Sheets(Template).Select
Sheets(Template).Copy After:=Sheets(Sheets.Count)
'make the sheet visible in case the template is hidden
ActiveSheet.Visible = xlSheetVisible
'Rename the sheet
ActiveSheet.Name = AccNumTextBox & str5
'Transfer Heading data
Set ws = Worksheets(AccNumTextBox & str5)
ws.Range("B8") = AccNumTextBox.Value
ws.Range("B9") = DTPicker4.Value
ws.Range("B10") = NameTextBox.Value
'Bring Data Entry sheet back to front if necesary
If chkBringToFront = False Then
Sheets("DataEntry").Select
End If
End Sub
As you're new to VBA, I've given an example that uses some aspects you might find useful in your coding future (a class and a collection).
Create a new class and call it cTemplate. Add the following properties:
Public Original As Worksheet
Public Suffix As String
Declare this module-level variable (ie at the top of your programme).
Private mTemplateList As Collection
Populate a collection with your template objects. (Note I've done this in a routing called "Initialise". If you don't have something similar then just call this routine in your Workbook_Open event).
I'd prefer to keep control of the template names, so you'll see that I've added them manually. In response to your question though, I've put a routine below it that reads the first row of a worksheet and takes out the template name, but it has no error handling and if anything should change in that list, your entire worksheet naming structure will be messed up.
Sub Initialise()
'
' /.../
'
Dim template As cTemplate
' Populate the collection with template and clone names.
Set mTemplateList = New Collection
Set template = New cTemplate
Set template.Original = ThisWorkbook.Worksheets("templateSavings")
template.Suffix = "Savings"
mTemplateList.Add template
Set template = New cTemplate
Set template.Original = ThisWorkbook.Worksheets("templateShares")
template.Suffix = "Shares"
mTemplateList.Add template
Set template = New cTemplate
Set template.Original = ThisWorkbook.Worksheets("templateStatements")
template.Suffix = "Statements"
mTemplateList.Add template
'
' Or if you really must read a row of previous worksheet names
' and you are certain the first row contains "1" then sheet name,
' use the following
'
Dim rng As Range
Dim cell As Range
dim str as String
Set mTemplateList = New Collection
' Quick and nasty row 1 selection -
' Adjust as you require for your own rows.
Set rng = ThisWorkbook.Worksheets("Sheet1").UsedRange.Resize(1)
' Read each cell to obtain the template sheet name
' Assumes each name has "1" and "template" at the start
For Each cell In rng.Columns
Set template = New cTemplate
str = Replace(cell.Text, "1", "")
Set template.Original = ThisWorkbook.Worksheets(str)
str = Replace(str, "template", "")
template.Suffix = str
mTemplateList.Add template
Next
End Sub
And finally, when a user adds a new account number, call the following routine.
Sub CreateNewTemplates(accountNumber As Long)
Dim template As cTemplate
Dim accountPrefix As String
Dim lastSheet As Worksheet
' Create prefix for worksheet names
accountPrefix = Format(accountNumber, "00000")
' Loop through the templates to copy
Set lastSheet = ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count)
For Each template In mTemplateList
template.Original.Copy After:=lastSheet
ActiveSheet.Name = accountPrefix & template.Suffix
Set lastSheet = ActiveSheet
Next
End Sub
Worksheet objects need careful error handling and your routine will need to check for duplicate account names, missing templates, etc. The same applies to your row reader for worksheet names. I'm afraid I'm typing at night with a fluey infant on my lap and she's just stirring, so I'll leave that bit for you.