I have a module that parses data from multiple workbooks with multiple sheets. However, while in the loop process I keep getting a message that a name already exist but whatever selection I make it keeps repeating the same message. I have tried enter a different name in the message box but it continues to repeat. Any ideas why I am getting this message?
Sub parse()
Dim WrkBookDest As Workbook
Dim WrkBookSrs As Workbook
Dim WrkSheetDest As Worksheet
Dim WrkSheetSrs As Worksheet
Set WrkBookDest = ThisWorkbook
FolderPath = "C:\attach\"
Filepath = FolderPath & "*.xlsx"
Filename = Dir(Filepath)
With WrkSheetSrs
WrkBookDest.Sheets("Sheet1").Range("A1") = .Range("A1").Value
WrkBookDest.Sheets("Sheet1").Range("A1").NumberFormat = .Range("A1").NumberFormat
WrkBookDest.Sheets("Sheet1").Range("B1") = .Range("A2").Value
WrkBookDest.Sheets("Sheet1").Range("B1").NumberFormat = .Range("A2").NumberFormat
WrkBookDest.Sheets("Sheet1").Range("C1") = .Range("B4").Value
WrkBookDest.Sheets("Sheet1").Range("C1").NumberFormat = .Range("B4").NumberFormat
WrkBookDest.Sheets("Sheet1").Range("D1") = .Range("B5").Value
WrkBookDest.Sheets("Sheet1").Range("D1").NumberFormat = .Range("B5").NumberFormat
WrkBookDest.Sheets("Sheet1").Range("E1") = .Range("B6").Value
WrkBookDest.Sheets("Sheet1").Range("E1").NumberFormat = .Range("B6").NumberFormat
WrkBookDest.Sheets("Sheet1").Range("F1") = .Range("B7").Value
WrkBookDest.Sheets("Sheet1").Range("F1").NumberFormat = .Range("B7").NumberFormat
End With
For i = 3 To 9
WrkBookDest.Sheets("sheet1").Range("G" & (i - 3) * 56 + 1) = WrkBookSrs.Sheets(i).Range("A2:C57").Value
Next
End Sub
One of the cells you are copying is a Defined Name (Formulas ► Defined Names ► Name Manager). By copying and pasting, Excel thinks you are trying to create a new and identical named range. Paste the values only. Change the Range.NumberFormat property in a separate operation.
The following uses direct cell value transfer then carries the Range.NumberFormat property across.
'selecting cells from Title sheet and parsing them to main workbook
With WrkSheetSrs
WrkBookDest.Sheets("Sheet1").Range("A1") = .Range("A1").Value
WrkBookDest.Sheets("Sheet1").Range("A1").NumberFormat = .Range("A1").NumberFormat
WrkBookDest.Sheets("Sheet1").Range("B1") = .Range("A2").Value
WrkBookDest.Sheets("Sheet1").Range("B1").NumberFormat = .Range("A2").NumberFormat
WrkBookDest.Sheets("Sheet1").Range("C1") = .Range("B4").Value
WrkBookDest.Sheets("Sheet1").Range("C1").NumberFormat = .Range("B4").NumberFormat
WrkBookDest.Sheets("Sheet1").Range("D1") = .Range("B5").Value
WrkBookDest.Sheets("Sheet1").Range("D1").NumberFormat = .Range("B5").NumberFormat
WrkBookDest.Sheets("Sheet1").Range("E1") = .Range("B6").Value
WrkBookDest.Sheets("Sheet1").Range("E1").NumberFormat = .Range("B6").NumberFormat
WrkBookDest.Sheets("Sheet1").Range("F1") = .Range("B7").Value
WrkBookDest.Sheets("Sheet1").Range("F1").NumberFormat = .Range("B7").NumberFormat
End With
For i = 3 To 9
WrkBookDest.Sheets("sheet1").Range("G" & (i - 3) * 56 + 1) = WrkBookSrs.Sheets(i).Range("A2:C57").Value
Next
Related
I'm having trouble creating Worksheet variables. I can't work out why the code below doesn't work. It is fine when I don't try to use the worksheet scheduleSheet (i.e. when I use the commented out line instead), but gives a compile error, "member or data method not found" when I try to use a worksheet variable. The problem seems to be when combining the worksheet variable with .CheckBox... as the rest of the code works (with scheduleSheet) when I comment out these lines (HT Olle Sjögren)
Sub Reset(sheetNamePrefix As String)
'reset sheet as blank
Application.EnableEvents = False
Dim scheduleSheetName As String
Dim constantsSheetName As String
Dim summarySheetName As String
Dim scheduleSheet As Worksheet
scheduleSheetName = sheetNamePrefix & "Schedule"
constantsSheetName = sheetNamePrefix & "Constants"
summarySheetName = sheetNamePrefix & "Summary"
Set scheduleSheet = ThisWorkbook.Sheets(scheduleSheetName)
'With Worksheets(scheduleSheetName)
With scheduleSheet
.CheckBox1.Value = False
.CheckBox2.Value = False
.Range("B4:G7,J4:L4").ClearContents
If LastCell(Worksheets(scheduleSheetName)).Row > 10 Then
.Range("A11:AA" + CStr(LastCell(Worksheets(scheduleSheetName)).Row)).Clear
End If
.Range("A11:A100").NumberFormat = "#" 'Clear
End With
With Worksheets(constantsSheetName)
.Range("A18:A24").Clear
.Cells(18, 1) = 2
.Cells(19, 1) = 1
.Cells(20, 1) = 180
.Cells(21, 1) = 15
.Cells(22, 1) = 360
.Cells(23, 1) = 30
.Cells(24, 1) = 40
.Cells(50, 1) = 0
End With
With Worksheets(summarySheetName)
.Range("C2:D6").ClearContents
.Range("D8:D19").ClearContents
.Range("D21:D25").ClearContents
.Range("D27:D33").ClearContents
End With
Application.EnableEvents = True
End Sub
I would check to make sure that scheduleSheetName is a valid sheet name. Put a break point after this variable is set and see if scheduleSheetName is a valid sheet name in your workbook.
Check to make sure that your checkboxes are named the same as what you have them named in the code.
If you use
.CheckBoxes("yourCheckBoxName").Checked
it should work.
I am a newcomer to VBA. I am trying to copy selected range from different workbooks and pasted to a target workbook with different sheetname correspondingly to the name of source file.
The code as below:
'open file
Sub RstChk()
Dim StrFileName As String
Dim StrFilePath As String
Dim TimeStr As String
Dim Version As Integer
Dim x As Workbook
Dim y As Workbook
Dim PstTgt As String
'define filename as array
Dim FN(10) As String
FN(1) = "CIO Wholesale"
FN(2) = "RMG"
FN(3) = "DCM"
FN(4) = "DivHeadOth"
FN(5) = "Runoff"
FN(6) = "Other Risk Subs"
FN(7) = "FIC"
FN(8) = "Treasury"
FN(9) = "Cash Equities"
FN(10) = "Global Derivatives"
'define file path
StrFilePath = "V:\RISKMIS\PUBLIC\apps\MORNING\RMU 1.5 Report\Consolidated\"
'define TimeStr
TimeStr = Format(Now() - 1, "mm-dd-yyyy")
Set y = Workbooks.Open("H:\Eform\Report_checking.xls")
'applying filename from array using loop
'----------------------------------------------------------------
For i = 1 To 10
'define changing file name with path & loop
For Version = 65 To 68
StrFileName = (StrFilePath & FN(i) & "_" & TimeStr & "_" & Chr(Version) & ".xls")
Set x = Workbooks.Open(StrFileName)
'-------------------------------------------------
If Chr(Version) = "A" Then
PstTgt = "A3"
ElseIf Chr(Version) = "B" Then
PstTgt = "E3"
ElseIf Chr(Version) = "C" Then
PstTgt = "I3"
Else
PstTgt = "M3"
End If
'copy the column and paste to report checking
y.Worksheets(FN(i)).PstTgt.Copy Destination = x.Sheets("Risk Summary").Range ("AA5:AC118")
Application.CutCopyMode = False
x.Close
Next Version
Next i
End Sub
I get error when I try to copy the range from source file (x) to target file (Y).
Run-time error '13', type mismatch
Just can't figure out what went wrong.
Thanks very much for your help.
Dan
You got this error because your variable PstTgt is a string and not a range "type mismatch"
If you look at the documentation of Range.Copy https://msdn.microsoft.com/en-us/library/office/ff837760.aspx
You have two choices :
Make PstTgt a range and referencing directly to the range in your endif
' Redefine PstTgt as a range
dim PstTgt as Range
' set value of PstTgt
If Chr(Version) = "A" Then
set PstTgt = y.Worksheets(FN(i)).Range("A3")
endif
...
' Copy the range where you want
PstTgt.Copy destination:=x.Sheets("Risk Summary").Range("AA5")
You keep your code like that and just correct your copy by adding Range
y.Worksheets(FN(i)).Range(PstTgt).Copy Destination = x.Sheets("Risk Summary").Range("AA5")
Here it is, I have a huge Excel workbook with which users write pricing quotes. On save, rather than saving the huge workbook, I'm transferring the relevant data to a text file and saving that text file. It's going off without a hitch, except for the one worksheet that contains formatting. I don't want the user to lose formatting when they load the previously saved quote (from the text file), so I need to determine a way to transfer that formatting data to and from the text file. Is there a smart way to do this without writing hundreds of lines of code or using any non-native Excel feature?
Here's a sample of the code for other sheets, but it's not much help for what I'm trying to do:
Sub WriteQuote()
Dim SourceFile As String
Dim data As String
Dim ToFile As Integer
Dim sh1, sh2, sh3 As Worksheet
Set sh1 = Sheets("sheet 1")
Set sh2 = Sheets("sheet 2")
Set sh3 = Sheets("sheet 3")
SourceFile = "C:\Users\███████\Desktop\test.txt"
ToFile = FreeFile
Open SourceFile For Output As #ToFile
'PRINT DETAILS TO TXT FILE
For i = 7 To 56
If sh1.Range("B" & i).Value <> "" Then
data = sh1.Range("B" & i).Value & "__"
If sh1.Range("D" & i).Value <> "" Then
data = data & sh1.Range("D" & i).Value & "__"
Else: data = data & " __"
End If
If sh1.Range("E" & i).Value <> "" Then
data = data & "ns" & "__"
Else: data = data & " __"
End If
data = data & sh1.Range("F" & i).Value & "__"
data = data & sh1.Range("G" & i).Value & "__"
data = data & sh1.Range("J" & i).Value & "__"
data = data & sh1.Range("M" & i).Value
Else: Exit For
End If
Print #ToFile, data
Next i
Close #ToFile
End Sub
This is an example using a user type ("record") and Random access IO.
There are limitations, and I believe using Random access
would probably waste space on disk, however it is a reasonable
way to go about doing this.
In the example I suggest using a bit mask for boolean properties,
for example "Bold" (a bit mask can save space and shorten the code).
The file read/write actions are based on :
https://support.microsoft.com/en-us/kb/150700
!!! It is possible that you'll get a "bad record length" error, although
every this is fine and works the first time. There are allot of reports about this issue (google VBA bad record length). If that is the case, you might want to change the IO to Binary instead of Random (code change will be needed).
!!!!! Add a module and paste the code there, or, for the very least,
paste the record in a module (not in a sheet).
Option Explicit
' Setting up a user type ("record").
' you can add more variables, however just makes sure they are fixed
' length, for example: integer\doube\byte\... Note that if you want to
' add a string, ' make sure to give it fixed length, as shown below.
Public Type OneCellRec
' this will hold the row of the source cell
lRow As Long
' this will hold the column of the source cell
lColumn As Long
' This will hold the value of the cell.
' 12 is the maximum length you expect a cell to have-
' CHANGE it as you see fit
Value As String * 12
' This hold the number format- again, you might need to
' twik the 21 length-
NumberFormat As String * 21
' will hold design values like Bold, Italic and so on
DesignBitMask1 As Integer
' will hold whether the cells has an underline- this is not boolean,
' as there are several type of underlines available.
UnderLine As Long
FontSize As Double
End Type
' ---- RUN THIS ---
Public Sub TestFullTransferUsingRec()
Dim cellSetUp As Range
Dim cellSrc As Range
Dim cellDst As Range
Dim r As OneCellRec
Dim r2 As OneCellRec
On Error Resume Next
Kill "c:\file1.txt"
On Error GoTo 0
On Error GoTo errHandle
' For the example,
' Entering a value with some design values into a cell in the sheet.
' --------------------------------------
Set cellSetUp = ActiveSheet.Range("A1")
cellSetUp.Value = 1.5
cellSetUp.Font.Bold = True
cellSetUp.Font.Size = 15
cellSetUp.Font.UnderLine = xlUnderlineStyleSingle
cellSetUp.NumberFormat = "$#,##0.00"
' Doing it again for example purposes, in a different cell.
Set cellSetUp = ActiveSheet.Range("C5")
cellSetUp.Value = "banana"
cellSetUp.Font.Bold = True
cellSetUp.Font.Size = 15
cellSetUp.Font.UnderLine = XlUnderlineStyle.xlUnderlineStyleDouble
' ============ saving the cells to the text file =============
' open file for write
Open "c:\file1.txt" For Random As #1 Len = Len(r)
' save to a record the value and the design of the cell
Set cellSrc = ActiveSheet.Range("A1")
r = MyEncode(cellSrc)
Put #1, , r
' save to a record the value and the design of the cell
Set cellSrc = ActiveSheet.Range("C5")
r = MyEncode(cellSrc)
Put #1, , r
Close #1
' ============ loading the cells from the text file =============
Application.EnableEvents = False
' open file for read
Dim i%
Open "c:\file1.txt" For Random As #1 Len = Len(r2)
' read the file
For i = 1 To Int(LOF(1) / Len(r))
Get #1, i, r2
' destination cell- write the value and design
' --------------------------------------------
Set cellDst = Sheet2.Cells(r2.lRow, r2.lColumn)
Call MyDecode(cellDst, r2)
Next
'Close the file.
Close #1
errHandle:
If Err.Number <> 0 Then
MsgBox "Error: " & Err.Number & " " & _
Err.Description, vbExclamation, "Error"
On Error Resume Next
Close #1
On Error GoTo 0
End If
Application.EnableEvents = True
End Sub
' Gets a single cell- extracts the info you want into a record.
Public Function MyEncode(cell As Range) As OneCellRec
Dim r As OneCellRec
Dim i%
i = 0
r.lRow = cell.row
r.lColumn = cell.column
r.Value = cell.Value
r.FontSize = cell.Font.Size
r.UnderLine = cell.Font.UnderLine
r.NumberFormat = cell.NumberFormat
' Use a bit mask to encode true\false excel properties.
' the encode is done using "Or"
If cell.Font.Bold = True Then i = i Or 1
If cell.Font.Italic = True Then i = i Or 2
'If cell. ..... .. = True Then i = i Or 4
'If cell. ..... .. = True Then i = i Or 8
'If cell. ..... .. = True Then i = i Or 16
'If cell. ..... .. = True Then i = i Or 32
'If cell. ..... .. = True Then i = i Or 64
'If cell. ..... .. = True Then i = i Or 128
'If cell. ..... .. = True Then i = i Or 256
' Remember the Integer limit. If you want more than int can handle,
' use long type for the i variable and r.DesignBitMask1 variable.
'If cell. ..... .. = True Then i = i Or ' (2^x)-
r.DesignBitMask1 = i
MyEncode = r
End Function
' Decode- write the info from a rec to a destination cell
Public Sub MyDecode(cell As Range, _
r As OneCellRec)
Dim i%
cell.Value = r.Value
i = r.DesignBitMask1
cell.Value = Trim(r.Value)
cell.Font.Size = r.FontSize
cell.Font.UnderLine = r.UnderLine
' trim is important here
cell.NumberFormat = Trim(r.NumberFormat)
' Use a bit mask to decode true\false excel properties.
' the decode is done using "And"
If i And 1 Then cell.Font.Bold = True
If i And 2 Then cell.Font.Italic = True
'If i And 4 Then ...
'If i And 8 Then ...
'...
End Sub
You could try TextToColumns. You're writing a delimiter in "__" that you could take advantage of. It also seems to keep the formatting of the cells when receiving the parsed text.
Sub ReadQuote()
SourceFile = "C:\Users\||||||\Desktop\test.txt"
Open SourceFile For Input As #8
Input #8, data
Range("M1") = data 'Temporary holder for an input line
'Range to start the parsed data "A1" in this example
Range("A1") = Range("M1").TextToColumns(, xlDelimited, , , , , , , , "__")
Close #8
End Sub
I tried searching for this a lot, but could not find a satisfactory answer. Sorry if it's a repost.
What I basically want is to merge multiple excel files into one workbook. I only want to keep the header row from the first excel file and ignore header row of the remaining excel files (as they are all the same). So the end result should be the Header + data from the first excel file and from the remaining excel file I only need the data rows, not the first row which has column heading similar to the first file.
The below copy paste all the rows and columns from all the excel files. Thank you for helping me.
For wbCounter = 1 To UBound(books)
Set wbSource = oExcel.Workbooks.Open(books(wbCounter))
For wsCounter = 1 To wbSource.Sheets.Count
Set wsSource = wbSource.Sheets(wsCounter)
If wsSource.Name Like selectSheetStr Then
emptySheet = True
If cbOptionIgnoreEmpty.Value = True And wsSource.UsedRange.Address = "$A$1" Then
emptySheet = True
Else
emptySheet = False
End If
If emptySheet = False Then
mergedWorksheetName = wsSource.Name
sheetExist = SheetExists(mergedWorksheetName, wbResult)
If (cbOptionAppendData.Value = True And sheetExist = True) Then
Set wsMergeResult = wbResult.Sheets(mergedWorksheetName)
wsSource.UsedRange.Copy
wsMergeResult.Cells(wsMergeResult.UsedRange.Rows.Count + 1, 1).Resize(wsSource.UsedRange.Rows.Count, wsSource.UsedRange.Columns.Count).PasteSpecial Paste:=xlPasteAll, Operation:=xlNone
mergedWorksheetCount = mergedWorksheetCount + 1
'Name of Worksheet
wsResult.Cells(mergedWorksheetCount + 1, 1) = wsMergeResult.Name
'Fullpath of Workbook
wsResult.Cells(mergedWorksheetCount + 1, 2) = wbSource.FullName
Else
wsSource.Copy After:=wbResult.Sheets(wbResult.Sheets.Count)
mergedWorksheetCount = mergedWorksheetCount + 1
wsResult.Cells(mergedWorksheetCount + 1, 1) = .ActiveSheet.Name
wsResult.Cells(mergedWorksheetCount + 1, 2) = wbSource.FullName
End If
End If
End If
Next wsCounter
wbSource.Close SaveChanges:=False
Next wbCounter
Try replacing the line...
wsSource.UsedRange.Copy
...with:
wsSource.UsedRange.Resize(wsSource.UsedRange.Rows.Count - 1, wsSource.UsedRange.Columns.Count).Offset(1, 0).Copy
This should copy the used range minus the frist row.
This code will get you the path of all the files in a specific folder
Option Explicit
Sub CountRows()
Dim MyObject As Scripting.FileSystemObject
Set MyObject = New Scripting.FileSystemObject
Dim mySource As Folder
Dim myFile As Scripting.File
Dim strPath As String
Set mySource = MyObject.GetFolder("D:\") ' or any other folder
For Each myFile In mySource.Files
strPath = myFile.Path
Next
End Sub
this code will open those workbooks and modify their cells
dim wrkbook as workbook
set wrkbook = workbooks.open(strPath) ' the path comes from the code above
'modify the workbook
wrkbook.worksheets.item(1).cells(1, 1) = "something"
I was forced to start to learn this by my employer. Unfortunately I was not given much time to prepare and I need to give results soon :-)
Here is something I was able to put together with assist of this forum - it's creating tabs for each day and naming them properly:
Sub Testovanie()
'
' Testovanie Macro
'
' Keyboard Shortcut: Ctrl+a
'
Dim pocet_tabov As Integer
Dim netusim As Integer
Dim sheet_meno As String
Dim string_pre_datum As String
Dim zadany_mesiac As Integer
Dim datum As Date
zadany_mesiac = 13
While (zadany_mesiac < 1) Or (zadany_mesiac > 12)
zadany_mesiac = Val(InputBox("Numeric month?"))
If zadany_mesiac = 0 Then Exit Sub
Wend
Application.ScreenUpdating = False
string_pre_datum = Str(zadany_mesiac) & "/1/" & Year(Now())
datum = CDate(string_pre_datum)
For pocet_tabov = 1 To 10
sheet_meno = Format((datum + pocet_tabov - 1), "dd.MMM.yyyy")
If Month(datum + pocet_tabov - 1) = zadany_mesiac Then
If pocet_tabov <= Sheets.Count Then
If Left(Sheets(pocet_tabov).Name, 5) = "Sheet" Then
Sheets(pocet_tabov).Name = sheet_meno
Else
Sheets.Add.Move after:=Sheets(Sheets.Count)
ActiveSheet.Name = sheet_meno
End If
Else
Sheets.Add.Move after:=Sheets(Sheets.Count)
ActiveSheet.Name = sheet_meno
End If
End If
Next pocet_tabov
For pocet_tabov = 1 To (Sheets.Count - 1)
For netusim = pocet_tabov + 1 To Sheets.Count
If Right(Sheets(pocet_tabov).Name, 10) > _
Right(Sheets(netusim).Name, 10) Then
Sheets(netusim).Move before:=Sheets(pocet_tabov)
End If
Next netusim
Next pocet_tabov
Sheets(1).Activate
Application.ScreenUpdating = True
End Sub
Now I need to copy prepared template from for example "C:\Troll\Template.xlsx" into all of theese created sheets. Additionally, template includes this formula: ='C:\Troll[source.xls]1.febr'!$U$33
I need this one to be updated in every new sheet. So the sheet with name 01.Feb.2014 needs to have template copied from [source.xls]1.febr'!$U$33, second sheet 02.Feb.2014 needs to have [source.xls]2.febr'!$U$33 and so on.
I was trying to do the copy - that worked. However I'm not able to join it with this one to be one big script.
Copying:
Public Function kopirovanie(sheet_meno As String)
Dim bWasClosed As Boolean
Dim cesta As String
Dim zdroj As Workbook
Dim ciel As Workbook
'Set ciel = Workbooks("template for copy.xlsx")
Set ciel = ActiveWorkbook ' for testing
' just in case the source wb is already open...
On Error Resume Next ' avoid the error if not open
Set zdroj = Workbooks("template for copy.xlsx")
On Error GoTo 0
If zdroj Is Nothing Then
bWasClosed = True
cesta = "C:\Project Tata\Kopirovanie\"
Set zdroj = Application.Workbooks.Open(cesta & "template for copy.xlsx")
End If
zdroj.Worksheets("Sheet1").Copy before:=ciel.Worksheets("Sheet1")
If bWasClosed Then
zdroj.Close False ' close without saving
End If
End Function
the function is supposed to be called after this
If pocet_tabov <= Sheets.Count Then
If Left(Sheets(pocet_tabov).Name, 5) = "Sheet" Then
Sheets(pocet_tabov).Name = sheet_meno
But I get error that copying is out of range. I think that I need to specify that it should copy regardless of the Tab name. Or actually I want it to copy into Active sheet...
the error is "Run-time error'9'" Subscript out of range.. and it marks me this one yellow: zdroj.Worksheets("Sheet1").Copy before:=ciel.Worksheets("Sheet1")
!! Look for the comments - part of this was already solved.
Now to continue with changing formula:
I have two docs. Lets call them Source.xls and Results.xls
Results doc has the macro you've wrote in it. That means we've copied 1 table that is exactly the same in all the newly created sheets - that's a part fo the job. However if I would do this with the table I have I would end up with Workbook created for 31 days of the month where is table with formula " ='C:\Troll[data_source.xls]1.febr'!$U$33 " .. this would end up with every day of Results showing results of the 1.st february of the data_source.
I need worksheet that was created for 1st feb, to get data from 1st feb, sheet for 2nd to get data from 2nd feb and so on.. Please be aware that source of table with formula and source of data which formula refers to are 2 different workbooks
I think this macro meets the first part of your requirement.
I have used your variable names when I am confident that I understand then. I have used my own names for other variables. I suggest you avoid renaming them until we have met your entire requirement.
I have not explained my new code. I did not want to spent time doing so if it does not meet your requirement. I am happy to explain anything you want to understand.
I use Excel 2003 so my extensions are different to yours. Change "xls" to "xlsx" before trying the macro.
I have three workbooks:
The workbook containing the macro.
The workbook containing the template worksheet. I have used your name for this workbook (except for the extension) but have changed the path to the folder holding the macro workbook.
The workbook created by the macro. I have named this Format(datum, "yyyy mmm"). Again I have changed the path to the folder holding the macro workbook.
You can change the paths immediately or you can wait until we have finished development.
Edit The remainder of this answer has been replaced.
The revised code below now updates the formula in cell C3 of each sheet created in WbookCreate. I believe I have made the correct change so the formula references the correct worksheet in workbook Source.xlsx.
However, I have made another change. In the original code, I named the created sheets as "dd.MMM.yyyy". I believe that was incorrect and I should have named then as "d.MMM". However, in the new code I name them as "d" and have added a statement to adjust the TabRatio. This means that all the tabs are visible at the same time. This is just a demonstration of what is possible; you can easily change to any name you prefer.
Option Explicit
Sub CreateDailySheets()
Const WbookCopyName As String = "template for copy.xls"
Dim datumCrnt As Date
Dim datumStart As Date
Dim Formula As String
Dim InxWbook As Long
Dim InxWsheet As Long
Dim PathCopy As String
Dim PathCreate As String
Dim PosLastSquare As Long
Dim PosLastQuote As Long
Dim WbookCopy As Workbook
Dim WbookCopyWasClosed As Boolean
Dim WbookCreate As Workbook
Dim WbookThis As Workbook
Dim zadany_mesiac As Long
Set WbookThis = ThisWorkbook
' These set the paths for the template workbook and the workbook to be
' created to that for the workbook containing the macro. Change as
' required.
PathCopy = WbookThis.Path
PathCreate = WbookThis.Path
' Check for template workbook being open
WbookCopyWasClosed = True
For InxWbook = 1 To Workbooks.Count
If Workbooks(InxWbook).Name = WbookCopyName Then
WbookCopyWasClosed = False
Set WbookCopy = Workbooks(InxWbook)
Exit For
End If
Next
If WbookCopyWasClosed Then
' Template workbook is not open so open it
Set WbookCopy = Workbooks.Open(PathCopy & "\" & WbookCopyName, True)
End If
' Create an empty workbook
Set WbookCreate = Workbooks.Add
' WbookCreate is now the active workbook
' Get the month of the current year for which workbook is to be created
zadany_mesiac = 13
While (zadany_mesiac < 1) Or (zadany_mesiac > 12)
zadany_mesiac = Val(InputBox("Numeric month?"))
If zadany_mesiac = 0 Then Exit Sub
Wend
'Calculate first day of target month
datumStart = DateSerial(Year(Now()), zadany_mesiac, 1)
datumCrnt = datumStart
' Loop until datumCrnt is within the next month
Do While Month(datumCrnt) = Month(datumStart)
' Copy template worksheet from template workbook and name for day
WbookCopy.Worksheets("Sheet1").Copy _
After:=WbookCreate.Worksheets(Worksheets.Count)
With ActiveSheet
' In original code, I had "dd.MMM.yyyy" but I believe this should have
' been "d.MMM". However, I have changed to just "d" because with the
' TabRatio set to .7 all the tab names are visible. You can change this
' easily to your preferred value.
.Name = Format((datumCrnt), "d")
Formula = .Range("C3").Formula
PosLastSquare = InStrRev(Formula, "]")
PosLastQuote = InStrRev(Formula, "'")
If PosLastSquare <> 0 And PosLastQuote <> 0 And _
PosLastQuote > PosLastSquare Then
' Sheet name is bracketed by PosLastSquare and posLastQuote
' Replace sheet name from template with one required for this sheet
Formula = Mid(Formula, 1, PosLastSquare) & Format((datumCrnt), "d.MMM") & _
Mid(Formula, PosLastQuote)
.Range("C3").Formula = Formula
End If
End With
datumCrnt = DateAdd("d", 1, datumCrnt)
Loop
' Delete default worksheet
With WbookCreate
' The default sheets are at the beginning of the list
Do While Left(.Worksheets(1).Name, 5) = "Sheet"
Application.DisplayAlerts = False ' Surpress "Are you sure" message
.Worksheets(1).Delete
Application.DisplayAlerts = True
Loop
.Worksheets(1).Activate
End With
ActiveWindow.TabRatio = 0.7
WbookCreate.SaveAs PathCreate & "\" & Format(datumStart, "yyyy mmm")
If WbookCopyWasClosed Then
' Template workbook was not open so close
WbookCopy.Close SaveChanges:=False
End If
End Sub