Save new file with filename cell value - excel

I am working on making a universal production time sheet(wbTime) for each dept that will work across all shifts and lines. I have where all the necessary information is required to be entered, all the data getting copied into a table in another workbook(wbLog) and saved to be able to do analysis on the production data.
However, when it gets to trying to save the actual time sheet in the proper folder according to shift and machine line I start running into problems. I have it pulling part of the path from certain cells and the filename form the date the enter. It is getting to the last line and throwing a run-time error 1004 "Method 'SaveAs' of object_Worbook'failed".
I have only been playing with vba for 2 months so it is probably something small that I just do not see...
Sub TransferData()
If ActiveSheet.Range("E2").Value = "" Then
MsgBox "Operator Name Required", vbInformation, "ALERT: Missing Information"
Cancel = True
Exit Sub
End If
If ActiveSheet.Range("H2").Value = "" Then
MsgBox "Date Required", vbInformation, "ALERT: Missing Information"
Cancel = True
Exit Sub
End If
If ActiveSheet.Range("K2").Value = "" Then
MsgBox "Shift Required", vbInformation, "ALERT: Missing Information"
Cancel = True
Exit Sub
End If
If ActiveSheet.Range("M2").Value = "" Then
MsgBox "Line Required", vbInformation, "ALERT: Missing Information"
Cancel = True
Exit Sub
End If
Dim wbTime As Workbook
Set wbTime = ThisWorkbook
Dim wbData As Workbook
Dim LastRow As Long
Set wbTime = ActiveWorkbook
With wbTime.Sheets("Production Time Sheet")
LastRow = .Range("E" & .Rows.Count).End(xlUp).Row
End With
wbTime.Sheets("Production Time Sheet").Range("A6:R" & LastRow).Copy
Set wbData = Workbooks.Open("S:\Lean Carrollton Initiative\Michael\Time Sheet Data LT Test.xlsm")
Set wbData = ActiveWorkbook
wbData.Worksheets("Log").Range("A" & Rows.Count).End(xlUp).Offset(1, 0).PasteSpecial xlPasteValues
wbData.Close SaveChanges:=True
Dim Fname As String
Dim Path As String
Dim shft As String
Dim Line As String
Set wbTime = ActiveWorkbook
Fname = Sheets("Production Time Sheet").Range("I2").Text
shft = Sheets("Production Time Sheet").Range("Z9").Text
Line = Sheets("Production Time Sheet").Range("AC11").Text
Path = "K:\Groups\OFS Time Sheets\8hr Production Schedule\LT Jacketing\" & shft & Line & Fname & ".xlsx"
ActiveWorkbook.SaveAs filename:=Path, FileFormat:=xlNormal
End Sub

You are using as name of file the text 2/5/2019.xlsx. As far as I know, the simbol / cannot be used in Windows to name a file.
Try with a different name for file. Something like:
Fname = Replace(Sheets("Production Time Sheet").Range("I2").Text,"/","-")

a) Don't use Range.Text, use Range.Value2.
Text will give you exactly what is written in the cell, and if the cell diplays ###because your cell is to narrow to display a number, it will give you ###.
b) Put a statement Debug.print path before the SaveAs and check in the immediate window (Ctrl+G) if the path is exactly what you expect.
c) Be sure that when you issue the SaveAs-command, the same file is not already open in Excel - this happens often when you test your code repeatedly (it may still open from the last test). SaveAs saves a copy of the file and keeps it open!
d) Use FileFormat:=xlOpenXMLWorkbook when you name the file with extension xlsx. xlNormal will save the file with the old Excel file format and expects xls as extension.
e) Try to save the file with exactly the name from the Excel SaveAs dialog to see if the filename is okay and you have permission to save a file.

Related

Excel crashing randomly when running macro

I'm having an issue with the following code, that is supposed to sequentially open 〜100 csv files, check for a value in a cell (validation, if it is file with correct structure), copy single line of data and paste it into ThisWorkbook.Worksheets("2 CSV").Range("B" & row_number).
This solution worked for two years until this month. Now the whole Excel crashes randomly on any file without any error message. Sometimes it manages to loop through 20 files, sometimes 5.
The weirdest thing is, that I can loop manually using F8 through the whole thing without any problem.
The macro:
Sub b_load_csv()
Dim appStatus As Variant
Dim folder_path As String 'folder path to where CSVs are stored
Dim file_name As String 'file name of current CSV file
Dim row_number As Integer 'row number in target sheet
Dim source_sheet_name As String 'name of the source sheet of the CSV = CSV file name
Dim wb_src As Workbook 'variable for opened CSV source workbook
Dim sht_src As Worksheet 'variable for opened CSV source sheet
Dim sht_csv As Worksheet 'variable for target sheet in ThisWorkbook
With Application
.Calculation = xlCalculationManual
.ScreenUpdating = False
.DisplayAlerts = False
If .StatusBar = False Then appStatus = False Else appStatus = .StatusBar 'show currently processing file in status bar
End With
folder_path = "C:\Folder\SubFolder\" 'here are the files stored
file_name = Dir(folder_path & "*.csv") 'using dir to get file names
row_number = 3 'row number for pasting values
Set sht_csv = ThisWorkbook.Worksheets("2 CSV") 'target sheet for data aggregation
Do While file_name <> ""
Workbooks.Open (folder_path & file_name), UpdateLinks:=False, Local:=True 'open csv file
Set wb_src = Workbooks(file_name) 'assign opened csv file to variable
source_sheet_name = Left(file_name, InStr(file_name, ".") - 1) 'sheet name in csv is the same as the file name
Set sht_src = wb_src.Worksheets(source_sheet_name) 'assign source sheet to variable
If sht_src.Range("C1").Value2 = "OJ_POPIS" Then 'checks if the csv has the correct structure
sht_src.Range("A2:FZ2").Copy 'if so copies desired range
sht_csv.Range("B" & row_number).PasteSpecial 'and pastes it into target worksheet column B
End If
sht_csv.Range("A" & row_number).Value2 = file_name 'writes file name into column A
Application.CutCopyMode = False
wb_src.Close SaveChanges:=False
file_name = Dir() 'fetch next file name
row_number = row_number + 1
'the following lines is what I tried to fix the problem of random excel crashing
Set wb_src = Nothing
Set sht_src = Nothing
Application.StatusBar = "Processing file " & file_name
DoEvents
Application.Wait (Now + TimeValue("0:00:02"))
ThisWorkbook.Save 'save after every loaded file to see which files are causing the problem
Loop
MsgBox "Data from CSV files copied", vbOKOnly
Set sht_csv = Nothing
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
Application.DisplayAlerts = True
End Sub
Source CSV files are encoded both in UTF-8 and ANSI (my ACP is ANSI, 1250) and ; delimited.
Group policy restricting macros doesn't apply to me. I can sign my own macros.
What I tried:
Lines of code at the end of the loop
Identifying and deleting files triggering the crash (they have nothing in common, seemingly random, by the time a remove half of them... what is the point)
Simplifying the macro
New workbook
Different machine
VPN On/Off
Thank you for your help!
First thing I'd try is include a proper error handler (not resume next), particularly with x64, and ensure 'Break on all unhandled errors' is selected in Tools / Options / General.
Second thing I'd try is avoid using the clipboard -
With sht_src.Range("A2:FZ2")
sht_cvs.Range("B" & row_number).Resize(.Rows.Count, .Columns.Count).Value = .Value
End With
(no need then to clear CutCopyMode)
Third thing I'd try is don't filter with Dir but something like this -
sFilter = "*.cvs"
file_name = Dir$(, 15) ' without vbDirectory if not getting subfolders
Do While Len(file_name)
If file_name Like sFilter Then
' process file
End If
file_name = Dir$(, 15)
Loop
Fourth thing I'd try is a good cup of coffee!

Excel VBA Workbook.Save Method taking >1 minute for changes on only 1 of 3 worksheets

I have a very odd duck problem with Excel VBA. I have a data file that is opened in VBA, written to and then closed. I have three separate worksheets within this same file that are similar but not the same, but none of them contain shapes, or other objects and relatively small amounts of data (usually less than 1000 rows by no more than 30 columns -- mostly numeric constant values) are being pasted into these worksheets. When two of the sheets are modified, it saves lickety split with no issues, but the third worksheet takes in excess of one minute to complete the save operation. The preceding code is almost exactly the same.
Set WBs = ThisWorkbook
Set WSs = WBs.Worksheets("SourceData")
LastRow = WSs.Range("B" & Rows.Count).End(xlUp).Row 'Finds row number of last row of data
Set WBd = OpenWorkbook(FileNam, FullPath:=True)
Set WSd = WBd.Worksheets("TroubledWorksheet")
''' CODE FOR COPYING DATA '''
Set Rng = WSs.Range("A20:AJ" & LastRow + 1)
WSd.Range("A2:AJ" & LastRowD).Clear
Rng.Copy WSd.Range("A2") 'copies all data from source to dest file
WSs.Columns("A:AI").Copy 'copy column width from source
WSd.Columns("A:AI").PasteSpecial Paste:=xlPasteColumnWidths 'paste column width to dest
ActiveWindow.DisplayZeros = False 'hides zeros in cells if formulas output is zero
WSd.Cells.FormatConditions.Delete 'clears Conditional Formatting for entire Sheet
WBd.Activate
WSd.Select
WSd.Range("A1").Select
Application.CalculateBeforeSave = False
' WBd.Save
WBd.Close SaveChanges:=True
Application.CalculateBeforeSave = True
I have uncommented the .Save in the above code with the same effect. I have also removed the .CalculateBeforeSave flags being set, also with no difference.
OpenWorkbook is a helper function that I use to open all of my workbooks.
''' ***************************************************************************
''' * OpenWorkbook()
''' * Preconditions: None
''' * Input: fname - File name
''' * show - boolean to show the workbook after opening
''' * FullPath - Boolean saying wheter it is partial or full path to wb
''' * Readonly - To open as Read Only or not
''' * Output: The Workbook Object
''' * This returns a workbook object of the specified file name. Checks to see
''' * if the Workbook is already open
''' ***************************************************************************
Public Function OpenWorkbook(fname As String, _
Optional show As Boolean = True, _
Optional FullPath As Boolean = False, _
Optional ReadOnly As Boolean = False, _
Optional UpdateLinks As Boolean = False, _
Optional AutoSave As Boolean = False) As Workbook
Dim wb As Workbook
Dim myFileName As String
Dim wbPath As String
Dim aPath() As String
On Error GoTo OpenWorkbookError
'If GEN_DEBUGGING Then Debug.Print "Enter OpenWorkbook #" & TimeInMS
Application.DisplayAlerts = False
Application.AskToUpdateLinks = False
wbPath = IIf(FullPath, fname, ReturnPath(fname))
If Right(wbPath, 4) Like "*xls*" Then
myFileName = wbPath
ElseIf Left(fname, 1) = "\" Or Left(fname, 1) = "/" Then
myFileName = wbPath & Mid(fname, 2) 'SelectFile(wbPath)
Else
myFileName = wbPath & fname
End If
On Error Resume Next
aPath = Split(myFileName, Delimeter)
Set wb = Workbooks(aPath(UBound(aPath)))
If wb Is Nothing Then Set wb = Workbooks.Open(myFileName, UpdateLinks:=UpdateLinks, ReadOnly:=ReadOnly)
On Error GoTo OpenWorkbookError
If wb Is Nothing Then
Err.Raise vbObjectError + 514, "Helper.OpenWorkbook", _
"Unable to Open " & myFileName & " Workbook"
Exit Function
Else
On Error Resume Next
wb.AutoSaveOn = AutoSave
On Error GoTo OpenWorkbookError
wb.Windows(1).Visible = show
End If
Set OpenWorkbook = wb
OpenWorkbookExit:
Application.DisplayAlerts = True
On Error GoTo 0
Exit Function
OpenWorkbookError:
MsgBox "Please ensure the workbook you are trying to open is at the specified location: " & _
vbCrLf & fname, vbCritical + vbOKOnly, "Error Opening Workbook"
HandleError "Helper.OpenWorkbook()"
Resume OpenWorkbookExit
End Function
This slow save for only one of the sheets has been observed by other members of my company. I have tried to pause the code before the save and save the workbook manually with the same result of a very prolonged save. Once I have saved it the first time it resumes normal behavior and saves quickly either in code or in the Excel application.
Any pointers or help would be greatly appreciated.
EDIT 1: I've updated the code for more completeness
EDIT 2: There was a similar post here: Too long saving time in Excel via VBA but it resolved itself. The problem I am experience is taking longer and longer. Today it took 11 minutes to save the file. The hangup is only on the .Save everything runs like clockwork right up until that point.
EDIT 3: It appears that some of the time it is now saving quickly and at other times it has continued to act slowly. There is no rhyme or reason behind these differences that I can pinpoint, they all occur when the data file was already created and previously saved, but other than that I am stumped.
EDIT 4: Resurrecting this post because this is becoming a rather serious slow-down in the operation. This behavior is only for Sheet(1) of the 3-sheet workbook, if I save to the other two sheets, this problem is non-existent. If I create a fresh workbook in code (a common occurrence) this problem does not happen, it is only when the data on Sheet(1) is replaced by the new data that we see this problem. Hopefully someone out there has seen something like this.
check your strategy for last row
LastRow = WSs.Range("B" & Rows.Count).End(xlUp).Row 'Finds row number of last row of data
can return ALL the worksheet, provoking lack of performance

Save file path according to worker matric number vba

I would like to save file in a "CONSOLIDATE FOLDER". But the file path should depend on staff working number ID (00639) where they input it in the "TEMPLATE" worksheet cell "N3". And in case staff forgot to input their working ID, there'll be a pop up box telling them to fill in their ID.
Any help really appreciated.
Sub MergeFile ()
Dim WB As Workbook
Dim WS as Worksheet
Dim FileName as String
Dim FilePath as String
Set WB = Workbook.Add
FilePath = "C:\Users\KGA00639\Desktop\CONSOLIDATE FOLDER"
FileName = ThisWorkbook.Worksheets("TEMPLATE").Range("L15").Value
For Each WS in ThisWorkbook.Worksheets
If WS.Name <> "TEMPLATE" Then
WS.Copy before:=WB.Sheets(1)
End if
If FileName = "" Then
FileName = InputBox ("You did not name the workbook" & vbCrLf & _
"Please write the name and press OK.:,"Setting the workbook name")
If FileName = "" Then Exit sub
ThisWorkbook.Worksheets("TEMPLATE").Range("L15").Value = FileName
End If
Next
ActiveWorkbook.SaveAs FileName:=FilePath & "\" & FileName
MsgBox ("Done"!)
ActiveWorkbook.Close
End Sub
This solution should come rather close to what you want. Please take a look.
Sub MergeFile()
' 056
Dim Wb As Workbook
Dim Ws As Worksheet
Dim FileName As String
Dim FilePath As String
Dim UserID As String
With ThisWorkbook.Worksheets("TEMPLATE")
UserID = .Cells(1, "A").Value ' change address to suit
FileName = .Range("L15").Value
If Left(UserID, 2) <> "ID" Then
MsgBox "You must enter your valid user ID in" & vbCr & _
"cell A1 of the 'Template' tab." & vbCr & _
"This program will now be terminated.", _
vbInformation, "Incomplete preparation"
.Activate
.Cells(1, "A").Select ' change to match above
Exit Sub
End If
End With
Application.ScreenUpdating = False
' use the UserID variable in whichever way you wish
FilePath = Environ("UserProfile") & "\" & UserID & "\Desktop\CONSOLIDATE FOLDER"
Set Wb = Workbooks.Add
For Each Ws In ThisWorkbook.Worksheets
If Ws.Name <> "TEMPLATE" Then
Ws.Copy Before:=Wb.Sheets(1)
End If
Next Ws
Wb.SaveAs FilePath & FileName, xlOpenXMLWorkbook
Application.ScreenUpdating = True
End Sub
You didn't specify where on the 'Template' tab the user ID would be found. The above code looks for it in cell A1. That cell is mentioned in 3 locations in the code (once in the message text). Please modify the code to match your facts.
You also didn't say where the UserID should appear in the FilePath. I placed it before the Desktop. I'm sure you will know how to amend that bit of code to suit you better.
When saving the workbook my code specifies an xlsx format. If this isn't what you want change the file format constant in the SaveAs line. I didn't think it a good idea to specify the extension in the 'Template'. You may like to move it to the code.
Finally, you didn't specify the next step after creation of the new workbook. So the code ends in the middle of nowhere. Excel made the new workbook the active one but you may like to close it, or ThisWorkbook, and determine what to do with the blank worksheet(s) still contained in the new book. There are a lot of lose ends still to tidy up. Good luck!

Trouble opening a specific workbook, and running a find formula to a userform

I have the code below, which works perfectly when run from a command button on sheet 6 of "filename.xlsx". (name changed, as it's a work file) It opens a userform, where I enter the date in a textbox (dateFind), it then populates 100 labels on the userform, then from sheet 29, it gets the appropriate week number.
Once it has all the info on the userform, it then moves it into tester.xlsx. and then saves the file using variables from the userform to create the filename. A quick check of the figures from the open userform to tester is done, then click OK on the message box to close form.
(Sorry if that's long winded, I thought the above might help to explain what I'm doing) :)
What I need it to do though is run from a button on another user form. This requires referencing the full filepath of the filename.xlsx as when it's run at work eventually, both "filename.xlsx" and "tester.xlsx" will be in different folders.
I've tried set = workbooks.open and then the full file path for both sheet 29 and sheet 6, and get a run time error 424. Object required. in sheet 29. I assume that that'll be the case for sheet 6 as well, but it's there.
Private Sub cb1_Click()
Dim wkbk As Workbook
Dim SubDate As Range
Dim WkNo As Range
Dim txt As String
Dim Filename As Variant
With Application
.EnableEvents = False
.ScreenUpdating = False
.DisplayAlerts = False
End With
'Suggested Edited code start
Set sourceWb = Workbooks.Open ("F:\Users\e-lia\Desktop\filename.xlsx" )
Set WkNo = sourceWb.Sheets("Sheet29").Range("A:A").Find(what:=dateFind.Value, LookIn:=xlValues, lookat:=xlWhole)
If Not WkNo Is Nothing Then
Me.WeekNo.Caption = WkNo.Offset(0, 1).Text
Else
MsgBox "Please check the date, and try again!"
End If
Set SubDate = sourceWb.Sheets("Sheet6").Range("A:A").Find(what:=dateFind.Value, LookIn:=xlValues, lookat:=xlWhole)
If Not SubDate Is Nothing Then
'Suggested Edited code end
Me.MON.Caption = SubDate.Offset(0, 0).Text ‘another 100 similar lines
Else
MsgBox "Please check the date, and try again!"
End If
Set wkbk = Workbooks.Open("F:\Users\e-lia\Desktop\tester.xlsx")
wkbk.Sheets(3).Range("M21") = MON.Caption ‘another 100 similar lines
ActiveWorkbook.SaveAs Filename:="F:\Users\e-lia\Desktop\filename for - Wk No." & WeekNo.Caption & " - for the Week ending " & FRI.Caption & ".xlsx"
MsgBox "The filename for Wk No. " & WeekNo.Caption & " and week ending " & FRI.Caption & " has been created and saved to the Desktop Folder."
wkbk.Close False
With Application
.EnableEvents = True
.ScreenUpdating = True
.DisplayAlerts = True
End With
End Sub
You may have been using the Codename instead of the actual Sheetname. The Sheetname is the name on the tab and the Codename is the name you will see in the project window not in parentheses. They can both be used, but there are different ways to use them. Looking at the example, you would refer to ThisWorkbook.Sheet1 using the codename and ThisWorkbook.Worksheets("Data") using the sheet name.

Auto copy-paste from Excel to Word works but no source formatting

I found a code on the Internet and I've adapted to my own use to automate copy-paste. Works great except that when I paste the Excel chart to my word report, the colors get changed to destination theme. I need to keep source formatting and as the report is final, I can't change the color scheme either.
For some reason Selection.PasteSpecial (wdChart) does not work, it's used as a simple paste. I've got hundreds of reports to paste two dozens of graphs to, please don't say I will have to do it manually! Help please!
'You must set a reference to Microsoft Word Object Library from Tools | References
Option Explicit
Sub ExportToWord()
Dim appWrd As Object
Dim objDoc As Object
Dim FilePath As String
Dim FileName As String
Dim x As Long
Dim LastRow As Long
Dim SheetChart As String
Dim SheetRange As String
Dim BookMarkChart As String
Dim BookMarkRange As String
Dim Prompt As String
Dim Title As String
'Turn some stuff off while the macro is running
Application.ScreenUpdating = False
Application.EnableEvents = False
Application.DisplayAlerts = False
'Assign the Word file path and name to variables
FilePath = ThisWorkbook.path
FileName = "Trust03.docx"
'Determine the last row of data for our loop
LastRow = Sheets("Summary").Range("A65536").End(xlUp).Row
'Create an instance of Word for us to use
Set appWrd = CreateObject("Word.Application")
'Open our specified Word file, On Error is used in case the file is not there
On Error Resume Next
Set objDoc = appWrd.Documents.Open(FilePath & "\" & FileName)
On Error GoTo 0
'If the file is not found, we need to end the sub and let the user know
If objDoc Is Nothing Then
MsgBox "Unable to find the Word file.", vbCritical, "File Not Found"
appWrd.Quit
Set appWrd = Nothing
Exit Sub
End If
'Copy/Paste Loop starts here
For x = 2 To LastRow
'Use the Status Bar to let the user know what the current progress is
Prompt = "Copying Data: " & x - 1 & " of " & LastRow - 1 & " (" & _
Format((x - 1) / (LastRow - 1), "Percent") & ")"
Application.StatusBar = Prompt
'Assign the worksheet names and bookmark names to a variable
'Use With to group these lines together
With ThisWorkbook.Sheets("Summary")
SheetChart = .Range("A" & x).Text
BookMarkChart = .Range("C" & x).Text
End With
'Tell Word to goto the bookmark assigned to the variable BookMarkChart
appWrd.Selection.Goto What:=wdGoToBookmark, Name:=BookMarkChart
'Copy the data from Thisworkbook
ThisWorkbook.Sheets(SheetChart).ChartObjects(1).Copy
'Paste into Word
appWrd.Selection.PasteSpecial (wdChart)
Next
'Turn everything back on
Application.ScreenUpdating = True
Application.EnableEvents = True
Application.DisplayAlerts = True
Application.StatusBar = False
'Let the user know the procedure is now complete
Prompt = "The procedure is now completed." & vbCrLf & vbCrLf
Title = "Procedure Completion"
MsgBox Prompt, vbOKOnly + vbInformation, Title
'Make our Word session visible
appWrd.Visible = True
'Clean up
Set appWrd = Nothing
Set objDoc = Nothing
End Sub
Rather than using the Selection.PasteSpecial method I use Application.CommandBars.ExecuteMso ("PasteSourceFormatting")
Change your paste line from
appWrd.Selection.PasteSpecial (wdChart)
to
appWrd.CommandBars.ExecuteMso ("PasteSourceFormatting")
appWrd.CommandBars.ReleaseFocus
Unfortunately MSDN doesn't have much in the way of documentation on this.... Hope it works for you without much trouble
EDIT
After some digging I figured out the the idMso parameter for this method corresponds to the ribbon controls idMso. A complete list of these can be found for each office application by going to File -> Options -> Customize Ribbon and then for each command hover over it in the list and the ToolTip will have a Description followed by a term enclosed in parentheses. This term in the parentheses is the idMso string for that command.
2nd EDIT
So here is how I do it from Excel to PowerPoint:
'Copy the object
Wkst.ChartObjects("ChartName").Select
Wkst.ChartObjects("ChartName").Copy
'Select Slide
Set mySlide = myPresentation.Slides("SlideName")
mySlide.Select
'stall to make sure the slide is selected
For k = 1 To 1000
DoEvents
Next k
'paste on selected slide
PPApp.CommandBars.ExecuteMso ("PasteSourceFormatting")
PPApp.CommandBars.ReleaseFocus
'sit and wait for changes to be made
For k = 1 To 5000
DoEvents
Next k
The wait loops with DoEvents (MSDN) are because this is within a loop pasting a dozen or so charts and then formatting them. I got errors in the next part of the loop (resizing the chart). But here I had to select the silde and wait for a moment before attempting the paste to make sure it was on the right slide. Without this it pasted on slide 1.
Nothing here sticks out to me as something you're ommitting but maybe it will help you see why it is not working.

Resources