This script is to reset a template, by copying a hidden worksheet template and deleting the existing sheet (after repopulating some reference data). I have tested it and it runs fine in debugging mode.
Option Explicit
Sub reset_PrintLayout_byCopy()
'the script replace the used printlayout with a copy from the hidden master.
Dim MeetingData() As String
Dim i As Integer
Dim j As Integer
Dim currentSheet As String
Dim datacolumns() As String
Dim userConfirm As String
ReDim Preserve MeetingData(3, 2)
ReDim Preserve datacolumns(2)
'warning about deleting data
userConfirm = MsgBox(Prompt:="Resetting the template will erase all data on the " _
& "PrintLayout Template. Choose ""Cancel"", if you wish to save the file first", _
Buttons:=vbOKCancel, Title:="Data to be erased!")
If (userConfirm = vbCancel) Then
Exit Sub
End If
'set parameters
datacolumns(0) = "D1"
datacolumns(1) = "I1"
'stop screen updating and displaying warnings
Application.ScreenUpdating = False
Application.DisplayAlerts = False
'set active sheet
currentSheet = ActiveSheet.Name
'capture meeting data already filled out
For j = 0 To UBound(datacolumns) - 1
For i = 1 To 3
If Worksheets(currentSheet).Cells(i, Range(datacolumns(j)).Column).Value <> "" Then
MeetingData(i - 1, j) = Worksheets(currentSheet).Cells(i, Range(datacolumns(j)).Column).Value
End If
Next i
Next j
'make hidden template visible
Worksheets("hiddenPrintLayoutTemplate").Visible = True
'Rename current Sheet
Sheets(currentSheet).Name = "used_Print_Layout"
''add a new sheet
' ActiveWorkbook.Worksheets.Add(before:=Sheets("used_Print_Layout")).Name = "PrintLayout Template"
'copy hiddentemplate before current sheet
Worksheets("hiddenPrintLayoutTemplate").Copy before:=Sheets("used_Print_Layout")
ActiveSheet.Name = currentSheet
'set rowheight for title rows
Range("A12").EntireRow.RowHeight = 24
Range("A18").EntireRow.RowHeight = 24
'delete current used printlayout
Worksheets("used_Print_Layout").Delete
'refilled meeting data
For j = 0 To UBound(datacolumns) - 1
For i = 1 To 3
If MeetingData(i - 1, j) <> "" Then
Worksheets(currentSheet).Cells(i, Range(datacolumns(j)).Column).Value = MeetingData(i - 1, j)
End If
Next i
Next j
'hide PrintLayout template
'Worksheets("hiddenPrintLayoutTemplate").Visible = xlSheetVeryHidden
'Sheets("PrintLayout Template").Select
'activate screenupdating and display warnings
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub
When run it in macro mode on button, it runs, but excel crashes, when it is done. I cannot find what the issue is. Any ideas?
I am not sure if by debugging you mean stepping through line by line, but you could try inserting stop statements at key points in the code. So for example, you could put a stop statement in the following part:
'capture meeting data already filled out
For j = 0 To UBound(datacolumns) - 1
For i = 1 To 3
If Worksheets(currentSheet).Cells(i, Range(datacolumns(j)).Column).Value <> "" Then
MeetingData(i - 1, j) = Worksheets(currentSheet).Cells(i,Range(datacolumns(j)).Column).Value
End If
Next i
Next j
stop
'make hidden template visible
Worksheets("hiddenPrintLayoutTemplate").Visible = True
You could see if the code runs fine up until that point (i.e. run it without debugging). If it does, remove the stop statement and place it further down the code. Repeat this until you find the statements which cause your crash - perhaps the reason would appear then.
In general, if you get an odd crash in Excel VBA, try switching the Windows default printer to Microsoft XPS Document Writer. Seems odd, but that has worked for me on problems where I've wasted many hours only to find this is the culprit.
Related
I have been running this code in my day to day work to keep on top of my orders and shipping, the code opens a spreadsheet in a specified location and returns the following, invoice number, company name, shipping date and total order value and puts them into one main spreadsheet.
I started using it last year and it used to take just under 3 minutes to run through about 400-500 spread sheets to collect the data. now I have a similar amount of data to run through this year but the report takes hours!!
I haven't changed my report and the data is the same data from the same template just in a different folder but in the same location on the same drive under the same parent folder.
I don't think it s the change of location that has slowed it down.
I have included a copy of my code below with notes under most of the code to explain the function of each line, can anyone see any problems with the code or recommend any improvements?
Sub Invoice_Records()
Dim objFSO As Object
Dim objFolder As Object
Dim objFile As Object
Dim FileExt As String
Dim CellValue As Range
Dim Text As String
Dim Text2 As String
Dim Text3 As String
Dim Total As Range
Dim filecountB As String
Dim i As String
Dim ws As Worksheet
Dim Invoice_Count As Integer
Set ws = Worksheets("Admin2")
'This part clears all columns, otherwise if you were on line 10 last time you ran the code,
'and then you deleted a commercial invoice it would only update up to line 9 but the legacy values of line 10 would still show
ws.Columns(2).EntireColumn.Clear
ws.Columns(3).EntireColumn.Clear
ws.Columns(4).EntireColumn.Clear
ws.Columns(5).EntireColumn.Clear
ws.Columns(6).EntireColumn.Clear
ws.Columns(7).EntireColumn.Clear
'Create an instance of the FileSystemObject
Set objFSO = CreateObject("Scripting.FileSystemObject")
'Get the folder object
Set objFolder = objFSO.GetFolder("C:\Users\king_matthew\Documents\ELINV 2018")
filecountB = objFolder.Files.Count
i = 1
'loops through each file in the directory and prints their names and path
For Each objFile In objFolder.Files
'print file name
ws.Cells(i + 1, 2) = objFile.Name
'print file path
ws.Cells(i + 1, 3).Select
ActiveSheet.Hyperlinks.Add Anchor:=Selection, Address:=objFile.Path, TextToDisplay:=objFile.Path
'Get the file extension
FileExt = Right(objFile.Name, Len(objFile.Name) - InStrRev(objFile.Name, "."))
'Paste file extension in column D
ws.Cells(i + 1, 4) = FileExt
If FileExt = "xlsm" Then
'This line stops the excel documents opening on your screen they just open in the background meaning your screen does not flicker
Application.ScreenUpdating = False
Application.StatusBar = True
Application.StatusBar = "Currently processing item " + i + " out of " + filecountB
'This opens the documents
Workbooks.Open Filename:=objFile.Path
'Tells VBA what you are looking for
Text = "Total Invoice Value"
'Find text, defined in line above
Set Match = ActiveSheet.Cells.Find(Text)
'Get the value of the cell next to cell found above
findoffset = Match.Offset(, 1).Value
'Paste this value in to column F
ws.Cells(i + 1, 6) = findoffset
'Tells VBA what else to look for
Text2 = "Order No:"
'Find Text2, defined in line above
Set Index = ActiveSheet.Cells.Find(Text2)
'If "Order No:" cant be found then do below if it is found skip to ELSE
If Index Is Nothing Then
'Tells VBA what else to look for
Text3 = "Date:"
'Find text, defined in line above
Set Match2 = ActiveSheet.Cells.Find(Text3)
'Get the value of the cell next to cell found above
findoffset = Match2.Offset(, 1).Value
'Close the workbook
ActiveWorkbook.Close
'Turn screen updating on so that you can see the values being updated
Application.ScreenUpdating = True
'Paste this value in to column F
ws.Cells(i + 1, 5) = findoffset
'Go onto the next file
i = i + 1
Else
'Paste the "Order No:" in column G
ws.Cells(i + 1, 7) = Index
'Tells VBA what else to look for
Text3 = "Date:"
'Find text, defined in line above
Set Match2 = ActiveSheet.Cells.Find(Text3)
'Get the value of the cell next to cell found above
findoffset = Match2.Offset(, 1).Value
'Close the workbook
ActiveWorkbook.Close
'Paste this value in to column F
ws.Cells(i + 1, 5) = findoffset
'Go onto the next file
i = i + 1
End If
Else
'If file extension is anything other than XLSM then leave the date blank
ws.Cells(i + 1, 5) = ""
'Go onto the next file
i = i + 1
End If
Next objFile
'Turn screen updating on so that you can see the values being updated
Application.ScreenUpdating = True
Application.StatusBar = False
Call FindingLastRow
End Sub
Sub FindingLastRow()
Dim ws As Worksheet
Dim ws2 As Worksheet
Dim lastRow As Long
Set ws = Worksheets("Admin2")
'Rows.count returns the last row of the worksheet (which in Excel 2007 is 1,048,576); Cells(Rows.count, "A")
'returns the cell A1048576, ie. last cell in column A, and the code starts from this cell moving upwards;
'the code is bascially executing Range("A1048576").End(xlUp), and Range("A1048576").End(xlUp).Row finally returns the last row number.
lastRow = ws.Cells(Rows.Count, "B").End(xlUp).Row
ws.Range("Row_Number").Value = lastRow
End Sub
Alright, so I changed a few things and removed some unnecessary code. Here is my "changelog":
Commented out call to FindingLastRow as it currently does nothing
Moved the 'Dims' around so that they are easier to read
Removed unused variables
Added variables for the temporary workbooks
I did this to avoid using ActiveSheet which will slow code down
NOTE: The line that sets wsTemp might not work correctly, let me know if it fails
Grouped the columns.clear calls you made
Changed starting value of i to 2 for simplicity
Added range variables to catch the Range.Find("..") results
Moved Application.ScreenUpdating call outside of loop
No reason to have it toggle so frequently inside of the loop itself
Added toggle to .Calculation and .EnableEvents to potentially speed program up further
They act similarly to .ScreenUpdating by suppressing excel and speed up by focusing on only certain operations
Removed the .select for the hyperlinks
Like calling Activesheet, calling .select will also slow code down
String concatenation for StatusBar uses & instead of +
Changed around how the if statements were used to clear out duplicate code
A couple times you were repeating code in the ifs when you can just do it right after them
Re-ordered the value pasting to match the columns theyre pasted in (ie C,D,E,F,G )
When calling cells using .cells(r,c) you can actually just use the column string, so I did that for simplicity
NOTE: your comments said that 'Date' would go in column F but your actual code put it in column E, so I chose to use E
Started using .value2 and .value when accessing/pasting text into cells
NOTE: added offset to the "order no" to match your other searches (it looked like an oversight)
I think that's it???
With all that in mind, here is the result. Hopefully it scales properly with your folder now :)
Sub Invoice_Records()
Dim ws As Worksheet
Set ws = Worksheets("Admin2")
Dim wbTemp As Workbook
Dim wsTemp As Worksheet
'Create an instance of the FileSystemObject
Dim objFSO As Object
Set objFSO = CreateObject("Scripting.FileSystemObject")
'Get the folder object
Dim objFolder As Object
Set objFolder = objFSO.GetFolder("C:\Users\king_matthew\Documents\ELINV 2018")
Dim objFile As Object
Dim i As Long
i = 2
Dim FileExtension As String
Dim filecountB As String
filecountB = objFolder.Files.count
Dim searchInvValue As Range
Dim searchOrderNum As Range
Dim searchDate As Range
'Toggling screen updating prevents screen flicker and speeds up operations
With Application
.ScreenUpdating = False
.Calculation = xlCalculationManual
.EnableEvents = False
.StatusBar = True
End With
'This part clears all columns, otherwise if you were on line 10 last time you ran the code,
'and then you deleted a commercial invoice it would only update up to line 9 but the legacy values of line 10 would still show
ws.Columns("B:G").EntireColumn.Clear
'Loops through each file in the directory
For Each objFile In objFolder.Files
'Update status bar to show progress
Application.StatusBar = "Currently processing item " & (i - 1) & " out of " & filecountB
'Paste file name
ws.Cells(i, "B").Value2 = objFile.Name
'Paste file path and add a hyperlink to it
ws.Hyperlinks.Add Anchor:=ws.Cells(i, "C"), Address:=objFile.path, TextToDisplay:=objFile.path
'Get the file extension
FileExtension = UCase$(Right(objFile.Name, Len(objFile.Name) - InStrRev(objFile.Name, ".")))
'Paste file extension
ws.Cells(i, "D").Value2 = FileExtension
'Only do operations on files with the extension "xlsm", otherwise skip
If FileExtension = "xlsm" Then
'This opens the current "objFile" document
Set wbTemp = Workbooks.Open(Filename:=objFile.path)
Set wsTemp = wbTemp.Sheets(1)
'Find and paste "Date:"
Set searchDate = wsTemp.Cells.Find("Date:")
ws.Cells(i, "E").value = searchDate.Offset(, 1).value
'Find and paste "Total Invoice Value"
Set searchInvValue = wsTemp.Cells.Find("Total Invoice Value")
ws.Cells(i, "F").Value2 = searchInvValue.Offset(, 1).Value2
'Find "Order No:" and paste if not blank
Set searchOrderNum = wsTemp.Cells.Find("Order No:")
If Not searchOrderNum Is Nothing Then ws.Cells(i, "G").Value2 = searchOrderNum.Offset(, 1).Value2
'Close the current "objFile" workbook
wbTemp.Close
End If
'Go onto the next file
i = i + 1
Next objFile
'Turn screen updating back on so that you can see the values being updated
With Application
.ScreenUpdating = True
.Calculation = xlCalculationAutomatic
.EnableEvents = True
.StatusBar = False
End With
'Call FindingLastRow 'this does not currently seem necessary
End Sub
UPDATED 3/30
So I adjusted the code and it runs error free now but the issue is that it does not pull the correct data. X basically starts with cell(X,1) and goes on from there. How do I link X to the selected listbox options in the array?
OLD Message:
I have a userform that allows for multi-select of Countries and also Questions about that specific country. These are stored in arrCountries & arrQuestion respectively. This then feeds to my main sub which calls for a Web Query Import from the CIA World Factbook site. I keep however getting a mismatch error that I cannot seem to sort out how to get around:
If I had to guess it is because when I am filling the array from the listbox's it is just adding a string and not the cell reference that the string is located at (or I am completely wrong).
My worksheet has only 1 sheet when started called Countries and the Column A is the URL and Column B is the Country name. I have Defined Public arrCountry(), Public arrQuestion(), and Public X as variant.
Code here:
Userform Code when click okay:
'Handles when the user clicks okay
Private Sub cbOkay_Click()
'Me.Hide
'Capture ticker selection(s) from list box.
Dim cI As Long
Dim cX As Long
Dim qI As Long
Dim qX As Long
'Stores the Countries selected into an array
If lbCountries.ListIndex <> -1 Then
For cI = 0 To lbCountries.ListCount - 1
If lbCountries.Selected(cI) Then
ReDim Preserve arrCountry(cX)
arrCountry(cX) = lbCountries.List(cI)
cX = cX + 1
End If
Next cI
End If
If cX = 0 Then MsgBox "Please select at least one country to analyse."
'MsgBox Join(arrCountry, vbCrLf)
'Stores the Questions selected into an array
If lbQuestions.ListIndex <> -1 Then
For qI = 0 To lbQuestions.ListCount - 1
If lbQuestions.Selected(qI) Then
ReDim Preserve arrQuestion(qX)
arrQuestion(qX) = lbQuestions.List(qI)
qX = qX + 1
End If
Next qI
End If
If qX = 0 Then MsgBox "Please select at least one question to analyse."
'MsgBox Join(arrQuestion, vbCrLf)
'Unload the form
Unload Me
cancel = False
End Sub
The message boxes return the correctly selected Listbox items so I know they are being stored correctly.
The WebQuery Code I am getting the error on:
UPDATED CODE:
So I added a loop counter:
Sub webQueryimport(arrCountry())
Dim mystr As String
Dim X As Integer
Dim selected As Variant
For Each selected In arrCountry
X = X + 1
Worksheets("Countries").Select
Worksheets("Countries").Activate
mystr = Cells(X, 1)
Worksheets.Add(After:=Worksheets(Worksheets.Count)).Name = selected
With ActiveSheet.QueryTables.Add(Connection:=mystr, Destination:=Range("$A$1"))
.WebSelectionType = xlEntirePage 'this tells VBA what to select and import
.WebFormatting = xlWebFormattingNone 'this turns off web formatting, otherwise text is various sizes
.Refresh BackgroundQuery:=False 'if commented out, doesn't add any data
End With
Next selected
End Sub
Again, now that loop works and will import but it always starts with the A1 no matter what is selected in the listbox and in arrCountries
Any thoughts/assistance would be great!
Got it:
Sub webQueryimport(arrCountry())
Dim mystr As String
Dim X As Integer
Dim rng As Range
Dim selected As Variant
Set rng = Range("B1")
For Each selected In arrCountry()
For X = 1 To 5 'rng.Offset(0, 0).End(xlDown).Rows.count
Worksheets("Countries").Select
Worksheets("Countries").Activate
If Cells(X, 2).Value = selected Then
mystr = Cells(X, 1).Value
Worksheets.Add(After:=Worksheets(Worksheets.Count)).Name = selected
With ActiveSheet.QueryTables.Add(Connection:=mystr, Destination:=Range("$A$1"))
.WebSelectionType = xlEntirePage 'this tells VBA what to select and import
.WebFormatting = xlWebFormattingNone 'this turns off web formatting, otherwise text is various sizes
.Refresh BackgroundQuery:=False 'if commented out, doesn't add any data
End With
End If
Next X
Next selected
End Sub
I needed to add in a counter and the IF statement to check to see if the value in the array matched the cell value in the sheet and then return the appropriate cell for the import.
I am using a Macro in Excel to loop through cells and write the data into a Template in Word. Everything worked completely fine until I wanted to add more cells to grab data from. Everything still works fine except once the variable I have name "j" gets to the value of 25, I get an error saying "Run-time error '5941': The requested member of the collection does not exist."
I've played around with using different rows and columns and every combination works. It is only when the "j" reaches 25 does the error occur. It is failing when it reaches the wrd.ActiveDocument.Tables(1).Rows(j)... line.
Sub Label_ExcelToWord_Single()
'Variable that stores file path for
'word template
Dim strpath As String
strpath = Cells(28, 8)
'opens Microsoft Word to edit template
Call OpenWord
Set wrd = GetObject(, "Word.Application")
wrd.Visible = True
wrd.Activate
wrd.ActiveDocument.Close savechanges:=False
wrd.Documents.Open strpath
'Variables used for loop data manipulation
Dim k As Integer
Dim j As Integer
k = 1
j = 1
'Primary loop responsible for exporting Excel
'data to word template
For Col = 1 To 3
For Row = 3 To 32
wrd.ActiveDocument.Tables(1).Rows(j).Cells(((Row - 3) Mod 7) + k).Range.Text = Cells(Row, Col) & vbCrLf & Cells(Row, Col)
If k = 7 Then
k = 0
j = j + 2
End If
If Col = 3 Then
If Row = 32 Then
'When we reach the last cell containing data exit routine
Exit Sub
End If
End If
k = k + 1
Next
Next
End Sub
I think it's a lot easier to use DocVariables in Word and push your data from Excel cells into the DocVariables. The end game is about the same, but I think the code is a lot easier to setup and maintain.
Sub PushToWord()
Dim objWord As New Word.Application
Dim doc As Word.Document
Dim bkmk As Word.Bookmark
sWdFileName = Application.GetOpenFilename(, , , , False)
Set doc = objWord.Documents.Open(sWdFileName)
'On Error Resume Next
objWord.ActiveDocument.variables("FirstName").Value = Range("FirstName").Value
objWord.ActiveDocument.variables("LastName").Value = Range("LastName").Value
objWord.ActiveDocument.variables("AnotherVariable").Value = Range("AnotherVariable").Value
objWord.ActiveDocument.Fields.Update
'On Error Resume Next
objWord.Visible = True
End Sub
Set a reference ot the MS Word Object Library.
Looks like the table might not have enough rows. If so, a brute-force way is to add rows as you need them:
...
For Col = 1 To 3
For Row = 3 To 32
' vvv new lines vvv
Do While wrd.ActiveDocument.Tables(1).Rows.Count < j
wrd.ActiveDocument.Tables(1).Rows.Add
Loop
' ^^^ new lines ^^^
...
I also recommend renaming j, k, Row, and Col to more descriptive names. You have Excel row/column indices and Word-table row/column indices, and it's easy to get them confused unless the names are clear.
(Note: Yes, the above code is slow, clunky, unoptimized, yadda yadda. Hopefully it will help the OP. :) )
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 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