I am trying to format the contents of an Excel file, and automatically save it in a specified location with a specified name via a dialog box. I have the codes below, but I am experiencing issues with the file format after I save the file. This is the issue that Excel prompts me:
This code allows me to format my excel file to the format I require, and then automatically shows the location and file name that I want to save it in. This codes allows me to save me excel file successfully. However, when I try to open it, it tells me that the file is corrupted, or that the extension is wrong.
Does anyone know why am I experiencing this error? Thanks!
Code:
Option Explicit
Sub externalRatingChangeFile()
'Declare the data type of the variables
Dim wks As Worksheet
Dim lastCol As Integer
Dim lastRow As Long
Dim iCol As Integer
Dim iRow As Long
Dim sFilename As String
Dim fdlg As FileDialog
Dim xlsxFileFormat As XlFileFormat
'Set wks to the current active worksheet
Set wks = ActiveWorkbook.ActiveSheet
Set fdlg = Application.FileDialog(msoFileDialogFilePicker)
'Set the location to save the file to a variable
sFilename = "H:\Testing File\Rating Change - " + Format(Date, "YYYYMMDD")
'xlsxFileFormat = XlFileFormat.xlOpenXMLWorkbook
'Within the current active worksheet, identify the last interested row and column of data
'Any values such as 'a', '1' or '%' are considered as values. Spaces (Spacebars) are not considered as values.
With wks
With .Cells(1, 1).CurrentRegion
lastCol = .Columns.Count
lastRow = .Rows.Count
End With
'Select the interested cells and insert borders around the interested fields
.UsedRange.Borders.LineStyle = xlContinuous
.UsedRange.Columns.AutoFit
End With
'Inserting a Row at the top to input Date
Range("A1").EntireRow.Insert
'Input today's Date
wks.Range("A1").Value = "Date: " + Format(Date, "DD MMMM YYYY")
'Save as .xlsx file in the specific location stated earlier
Set fdlg = Application.FileDialog(msoFileDialogSaveAs)
With fdlg
.InitialFileName = sFilename
.Show
'If there are errors in the code, set wks to nothing and end the process
On Error GoTo err_handler
wks.SaveAs (fdlg.SelectedItems(1))
End With
'System to/not display alerts to notify Users that they are replacing an existing file.
Application.DisplayAlerts = True
err_handler:
'Set wks to its default value
Set wks = Nothing
End Sub
I assume your are starting with a CSV or other non excel format (text file etc...)
If you change the line that actually saves the file to
wks.SaveAs (fdlg.SelectedItems(1)) , FileFormat:=xlOpenXMLWorkbook
that will force the VBA to save the file in the "correct" format. It would be better to actually pick up the format selected in the dialogue but I dont think it is returned except in the file extension. You could detect that and then choose the matching format but if you are always saving as XLSX then you could just use the above method.
Related
Picture above is the master workbook. Can anyone help me to write the vba so it will find workbooks throughout the root folder (e.g. C:\Work\2017) that match with the account number and copy the B9 and E9 cells to the master cell. The 2nd picture is a system generated workbook with random name (e.g. export!-097a0sdk.xls), that's why I need a shortcut to make this task easier.
This is the result I expected by using the code
This is the excel generated by system
Thank you
If I understood correctly then the following will loop through a given directory and it will open and check each file for the required information, if found, it will add the values to your Master workbook.
Note: This code will not open a file if it has "Master" in its filename.
Sub LoopThroughFolder()
Dim FSO As New FileSystemObject
Dim myFolder As Folder
Dim wb As Workbook
Dim ws As Worksheet: Set ws = ThisWorkbook.Worksheets("Sheet1")
Dim myFile As File
Dim AccNumber As String
Dim LastRow As Long, i As Long
Dim sPath As String
sPath = "C:\Work\2017"
LastRow = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row
'get the last row with data on Column A
Application.DisplayAlerts = False
'do not display alerts
Set myFolder = FSO.GetFolder(sPath) 'set the root folder
For Each myFile In myFolder.Files 'for each file in the folder
If InStr(myFile.Name, "Master") = 0 Then
'if file to open does not have "Master" in it's name then
Set wb = Workbooks.Open(myFile.Path) 'open the file
AccNumber = wb.Sheets(1).Range("B2") 'check for account number on first Sheet
For i = 1 To LastRow 'loop through current Sheet to check if we have a match for the account number
If ws.Cells(i, 1) = AccNumber Then 'if match
ws.Cells(i, 2) = wb.Sheets(1).Range("B9") 'pass the values from the required range
ws.Cells(i, 3) = wb.Sheets(1).Range("E9")
End If
Next i
wb.Close False 'close and do not save changes
Set wb = Nothing
End If
Next
Application.DisplayAlerts = True
End Sub
Also you might have to set a reference to the relevant library to use FileSystemObject, to do that:
How do I use FileSystemObject in VBA?
Within Excel you need to set a reference to the VB script run-time library.
The relevant file is usually located at \Windows\System32\scrrun.dll
To reference this file, load the
Visual Basic Editor (ALT+F11)
Select Tools > References from the drop-down menu
A listbox of available references will be displayed
Tick the check-box next to 'Microsoft Scripting Runtime'
The full name and path of the scrrun.dll file will be displayed below the listbox
Click on the OK button.
I have a directory with 6 sub-folders and ~300 excel workbooks(Growing every day).
Each workbook has multiple formulas (~1200 per workbook) that reference a CSV data dump stored on a server path.
My issue is that excel treats the CSV data dump as "dirty data" and prompts warnings every time a workbook is opened claiming it can't update the links(But when the links are checked, excel then says there's no issue).
In all my research I've found there doesn't seem to be a way to fix this other than replace the datasource with a .xsl file which excel doesn't have any issues referencing.
What I need to do, is perform a find and replace on ~300 workbooks, find the CSV server path inside the formulas and replace it with the new server path for the .xls file.
I've tried "Sobolsoft's Excel Find and Replace" software, but that doesn't seem to want to look inside formulas to replace. I've used "Easy-XL" and "Kutools" both of which only work on open workbooks (Which I could live with, if I had to open 20-50 workbooks at a time, run the find and replace, then open the next batch) but neither of them wanted to work either.
I've used the following macro to unprotect/protect each workbook in the directory which works perfectly
Const cStartFolder = "M:\Transfer\DrillHole_Interaction\4.For_Survey" 'no slash at end
Const cFileFilter = "*.xlsm"
Const cPassword = "" 'use empty quotes if blank
Sub UnprotectAllWorksheets()
Dim i As Long, j As Long, arr() As String, wkb As Workbook, wks As Worksheet
ExtractFolder cStartFolder, arr()
On Error Resume Next
j = -1: j = UBound(arr)
On Error GoTo 0
For i = 0 To j
Set wkb = Workbooks.Open(arr(i), False)
For Each wks In wkb.Worksheets
wks.Protect cPassword, True, True
Next
wkb.Save
wkb.Close
Next
End Sub
Sub ExtractFolder(Folder As String, arr() As String)
Dim i As Long, objFS As Object, objFolder As Object, obj As Object
Set objFS = CreateObject("Scripting.FileSystemObject")
Set objFolder = objFS.GetFolder(Folder)
For Each obj In objFolder.SubFolders
ExtractFolder obj.Path, arr()
Next
For Each obj In objFolder.Files
If obj.Name Like cFileFilter Then
On Error Resume Next
i = 0: i = UBound(arr) + 1
On Error GoTo 0
ReDim Preserve arr(i)
arr(i) = objFolder.Path & Application.PathSeparator & obj.Name
End If
Next
End Sub
If it would help, I'm also open to copying from a 'Master' workbook and copying the specific range into each other workbook (Copy range to range for each book) but I'm at my wits end and do not know how to proceed.
Any help would be appreciated.
No need to find and replace the csv fullname (path & filename) within all formulas, just change the links source at once within each workbook.
Try this within a loop through all workbooks that need to be changed.
Dim Wbk As Workbook
Application.DisplayAlerts = False
Set Wbk = Workbooks.Open(Filename:="WbkTarget.Fullname", UpdateLinks:=3)
With Wbk
.ChangeLink _
Name:="CsvFile.Fullname", _
NewName:="XlsFile.Fullname", _
Type:=xlExcelLinks
.Save
.Close
End With
Application.DisplayAlerts = True
where:
WbkTarget.Fullname: Path and name of the workbook with the link to be replaced
CsvFile.Fullname: Path and name of the csv file to be replaced
XlsFile.Fullname: Path and name of the xls that replaces the csv file
So I have been going around in circles trying to find an answer to what should be a basic file combination.
I have a weeks worth of CSV files generated.
I need to combine the files into a single worksheet with the data stacked
Original file has 2 of the columns that are date and time combined (d/mm/yyyy h:mm:ss)
I have my VBA code combining the data as required but the time formatting is screwed in the master file (d/mm/yyyy h:mm)
Can someone help please with my code :(
Option Explicit
Sub ImportCSVsWithReference()
'Summary: Import all CSV files from a folder into a single sheet
' adding a field in column A listing the CSV filenames
Dim wbCSV As Workbook
Dim wsMstr As Worksheet: Set wsMstr = ThisWorkbook.Sheets("MasterCSV")
Dim fCSV As String
Dim fList As String
Dim fName As String
Dim fd As FileDialog
Dim FileChosen As Integer
Dim FileName As String
Dim i As Integer
Dim wbCSVDisplayOrder As Long
Dim M As Long
'Select the correct files for merge
Set fd = Application.FileDialog(msoFileDialogFilePicker)
'use the standard title and filters, but change the
'initial folder
fd.InitialFileName = "C:\RTVis\OT"
fd.InitialView = msoFileDialogViewList
'allow multiple file selection
fd.AllowMultiSelect = True
FileChosen = fd.Show
If FileChosen = -1 Then
'open each of the files chosen
For i = 1 To fd.SelectedItems.Count
Workbooks.Open fd.SelectedItems(i)
Next i
End If
'clear master page of previous data
If MsgBox("Clear the existing MasterCSV sheet before importing?", vbYesNo, "Clear?") _
= vbYes Then wsMstr.UsedRange.Clear
Application.ScreenUpdating = False 'speed up macro
'Combine files
'start the CSV file listing
fCSV = Dir(fName & "*.csv")
Do While Len(fCSV) > 0
'open a CSV file
Set wbCSV = Workbooks.Open(fName & fCSV)
'copy date into master sheet and close source file
ActiveSheet.UsedRange.Copy wsMstr.Range("A" & Rows.Count).End(xlUp).Offset(0)
wbCSV.Close False
'ready next CSV
fCSV = Dir
Loop
Application.ScreenUpdating = True
End Sub
If I understand you correctly, your problem is with the date/time formatting being munged by Excel when you open the file, but the parsing works properly otherwise.
When Excel sees what looks like a date, it will try to interpret it in accord with your Windows Regional Settings. So if the date in the file is DMY, and your settings at MDY, the dates will not be interpreted properly.
Workaround 1: Change your windows regional settings to match those in the CSV file
Workaround 2: Use the QueryTables method. You can get the VBA equivalent by using the macro recorder and executing, from native Excel, Data ► Get External Data ► From Text Files This will allow specification of the date format. But you must be careful about not adding them multiple times but by refreshing them instead or first deleting them and then adding them again.
Workaround 3: Write your own parsing routine to parse the raw data. Probably should use the FileSystemObject if doing this.
Workaround 4: Change the file suffix to something other than .csv, and then use the OpenText method. This requires the least changes to your existing code. You create a new file; import that; then delete it. The code below demonstrates that process, but does NOT do the other things that you want.
If you use 4, you should add some error handling in case the file copy / delete process goes awry. My favorite options would be 2 or 3.
Sample Code
Option Explicit
Sub foo()
Dim WB As Workbook, wbCSV As Workbook, swbCSV As String
Dim sFN As String, sCopyFN
Dim FD As FileDialog
Set WB = ThisWorkbook
Set FD = Application.FileDialog(msoFileDialogFilePicker)
With FD
.AllowMultiSelect = False
.Filters.Add "Text or CSV", "*.txt, *.csv", 1
.Show
sFN = .SelectedItems(1)
End With
'If CSV, remove suffix
sCopyFN = ""
If sFN Like "*.csv" Then
sCopyFN = Left(sFN, Len(sFN) - 4)
FileCopy sFN, sCopyFN
sFN = sCopyFN
End If
Workbooks.OpenText Filename:=sFN, DataType:=xlDelimited, origin:=437, _
TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=True, Tab:=False, _
Semicolon:=False, Comma:=False, Space:=True, Other:=False, _
FieldInfo:=Array(Array(1, xlDMYFormat), Array(2, xlGeneralFormat))
Set wbCSV = ActiveWorkbook
'Get path as string since it will not be available after closing the file
swbCSV = wbCSV.FullName
'Move the data into this workbook
Dim rCopy As Range, rDest As Range
With WB.Worksheets("sheet1")
Set rDest = .Cells(.Rows.Count, 1).End(xlUp)
End With
Set rCopy = wbCSV.Sheets(1).UsedRange
rCopy.Copy rDest
'must close the file before deleting it
wbCSV.Close False
Kill swbCSV
End Sub
I have a problem. I'm guessing its easier to first write the code, and then explain it so here goes:
Sub Test()
Dim myHeadings() As String
Dim i As Long
Dim path As String
Dim pathtwo As String
Dim currentWb As Workbook
Dim openWb As Workbook
Dim openWs As Worksheet
Set currentWb = ActiveWorkbook
path = "C:\pathto\"
pfile = Split("File1,File2,File3", ",")
myHeadings = Split("Januari,Februari,Mars,April,Maj,Juni,Juli,Augusti,September,Oktober,November,December", ",")
For j = 0 To UBound(pfile)
pathtwo = path & pfile(j) & ".xlsx"
i = 0
If IsFile(pathtwo) = True Then
For i = 0 To UBound(myHeadings)
Set openWb = Workbooks.Open(pathtwo)
Set openWs = openWb.Sheets(myHeadings(i))
If openWs.Range("C34") = 0 Then
currentWb.Sheets("Indata").Cells(70, i + 27 + 12*j.Value = ""
Else
currentWb.Sheets("Indata").Cells(70, i + 27 + 12*j).Value = openWs.Range("C34")
End If
Next i
End if
Workbooks(openWb.Name).Close
Next j
End sub
What I want to pick a file from the pfile list, iterate through all its sheets defined in myHeadings and deduct the value at C34 (in reality there are plenty more values deducted, but to keep it short). After this I want to Close the file, go to the next file and do the same thing until all the Three files (again, in reality there are more, which some of them does not exist yet).
The function "IsFile" is
Function IsFile(fName As String) As Boolean
'Returns TRUE if the provided name points to an existing file.
'Returns FALSE if not existing, or if it's a folder
On Error Resume Next
IsFile = ((GetAttr(fName) And vbDirectory) <> vbDirectory)
End Function
written by iDevlop at stackoverflow, in this thread: VBA check if file exists
The reason why I have
currentWb.Sheets("Indata").Cells(70, i + 27 + 12*j).Value = openWs.Range("C34")
is because I want to start to write my data into currentWb at AA70 (Row 70, column 27). j*12 is because it is "periodic" depending on which file it is (the file file1 corresponds to 2015, file2 to 2016 etc), and hence in my summary I have it month and yearwise.
The problem arises though when I run this macro, at the first file at the sheet Mars I get out of range, but Before I added the iteration of files, there was not any subscript out of range at the first file. Is there anyone who can see how this can be?
Please note that indentation and so on may be somewhat off as I copied this from a much larger file with many rows in between with irrelevant code.
This isnt the right answer for your specific question but this is how I have done something similar and might help you to see how i did it. Basically what this is doing is opening up a CSV and copying the entire sheet and pasting it into a workbook. I was consolidating like 20 CSV dumps into 1 workbook to make it easier to dig through the stuff.
Regarding Dir()
You can invoke Dir with 2 arguments or with no arguments. You initialize it with 2 arguments the pathway and the attributes (which is optional). The 2nd time I am calling Dir in this sub it is without any arguments. What this does is fetch the subsequent files.
Sub Add_Sheets()
Dim ws As Worksheet
Dim PasteSheet As Worksheet
Dim wb As Workbook
Set wb = Application.Workbooks.Open("C:\Users\Desktop\CSV\All.xlsx") 'Location of where you want the workbook to be
StrFile = Dir("c:\Users\Desktop\CSV\*.csv") 'Dir of where all the CSVs were.
Do While Len(StrFile) > 0
Debug.Print StrFile
Application.Workbooks.Open ("c:\Users\Desktop\CSV\" & StrFile)
Set ws = ActiveSheet
ws.Range("A1:C" & rows.Count).Select 'Selecting Specific content on the worksheet
Selection.Copy
wb.Activate
wb.Worksheets.add(After:=Worksheets(Worksheets.Count)).name = StrFile 'Setting the sheet name to the name of the CSV file
Range("A1").PasteSpecial Paste:=xlPasteValues
StrFile = Dir
Loop
End Sub
I'm trying to optimize some code that takes some test data stored in CSV files does some analysis and copies their data into an excel sheet. This code is often run on hundreds of tests at a time, and its taking about 4.5 seconds per test so it can take hours to complete at times.
I looked up some optimization techniques and cut it down by about .25 seconds per test but I think the bulk of the time is being taken up by excel having to "open" the individual files before it can do anything with them. Is there a way to do this more efficiently?
I am open to answers that involve using another language to compile the files into one big file if that would make things quicker.
I would open them as text rather than workbooks:
Sub ReadCSV()
Dim MyString As String
Open "C:\path\text.csv" For Input As #1 ' Open file for input.
Do While Not EOF(1) ' Loop until end of file.
Line Input #1, MyString ' Read a line into variable
Debug.Print MyString ' Print data to the Immediate window.
Loop
Close #1 ' Close file.
End Sub
This will be much faster than opening as a workbook
I have this function working greate handling lot of CSV files. You need to indicate in cell "D11" the name of folder containing all the CSV files and will combine them into one single file. I handle over 200 files and make it quick. Hope it helps.
Sub CombineAllFilesInADirectory()
Dim Path As String 'string variable to hold the path to look through
Dim FileName As String 'temporary filename string variable
Dim tWB As Workbook 'temporary workbook (each in directory)
Dim tWS As Worksheet 'temporary worksheet variable
Dim aWS As Worksheet 'active sheet in master workbook
Dim RowCount As Long 'Rows used on master sheet
Dim uRange As Range 'usedrange for each temporary sheet
Dim mWB_comb As Workbook 'master workbook exclusivo de esta funcion
Path = Sheets("CombineFiles").Range("D11").Value
Application.EnableEvents = False 'turn off events
Application.ScreenUpdating = False 'turn off screen updating
Set mWB_comb = Workbooks.Add(1) 'create a new one-worksheet workbook
Set aWS = mWB_comb.ActiveSheet 'set active sheet variable to only sheet in mWB
If Right(Path, 1) <> Application.PathSeparator Then 'if path doesnt end in "\"
Path = Path & Application.PathSeparator 'add "\"
End If
FileName = Dir(Path & "*.csv", vbNormal) 'set first file's name to filename variable
Application.StatusBar = "reading files, please wait."
Do Until FileName = "" 'loop until all files have been parsed
If Path <> ThisWorkbook.Path Or FileName <> ThisWorkbook.Name Then
Set tWB = Workbooks.Open(FileName:=Path & FileName) 'open file, set to tWB variable
For Each tWS In tWB.Worksheets 'loop through each sheet
Set uRange = tWS.Range("A4", tWS.Cells(tWS.UsedRange.Row + tWS.UsedRange.Rows.count - 1, _
tWS.UsedRange.Column + tWS.UsedRange.Columns.count - 1)) 'set used range
If RowCount + uRange.Rows.count > 65536 Then 'if the used range wont fit on the sheet
aWS.Columns.AutoFit 'autofit mostly-used worksheet's columns
Set aWS = mWB_comb.Sheets.Add(After:=aWS) 'add a new sheet that will accommodate data
RowCount = 0 'reset RowCount variable
End If
If RowCount = 0 Then 'if working with a new sheet
aWS.Range("A1", aWS.Cells(3, uRange.Columns.count)).Value = tWS.Range("A1", _
tWS.Cells(3, uRange.Columns.count)).Value 'copy headers from tWS
RowCount = 3 'add one to rowcount
End If
aWS.Range("A" & RowCount + 1).Resize(uRange.Rows.count, _
uRange.Columns.count).Value = uRange.Value 'move data from temp sheet to data sheet
RowCount = RowCount + uRange.Rows.count 'increase rowcount accordingly
Next 'tWS
tWB.Close False 'close temporary workbook without saving
End If
FileName = Dir() 'set next file's name to FileName variable
Loop
Application.StatusBar = "Ready"
mWB_comb.Sheets(1).Select 'select first data sheet on master workbook
Application.EnableEvents = True 're-enable events
Application.ScreenUpdating = True 'turn screen updating back on
'Clear memory of the object variables
Set tWB = Nothing
Set tWS = Nothing
Set mWB_comb = Nothing
Set aWS = Nothing
Set uRange = Nothing
End Sub