VBA changes date format when a CSV file saved as XLSX - vba
I have a csv file which has column D with dates entered and formatted under the australian date format. The rest of data is integers:
4/10/2016 (correctly representing 4 Oct 16)
15/03/2017 (correctly representing 15 Mar 17)
When I save this file manually as xlsx it correctly saves the dates so when I reopen the xlsx file the dates appear correctly:
value = 4/10/2016, format = 4/10/2016 (as dd/mm/yyyy)
value = 15/03/2017, format = 15/03/2017 (as dd/mm/yyyy)
However, when I do the same thing programmatically:
fileNameXLSX = "H:\20160930.xlsb"
fileNameCSV = "H:\20160930.csv"
Set srcBook = Application.Workbooks.Open(filenameCSV, ReadOnly:=True)
Application.DisplayAlerts = False
srcBook.SaveAs filename:=fileNameXLSX, FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False
srcBook.Close False
Set srcBook = Nothing
Application.DisplayAlerts = True
and open the file, some entries, months/dates get swapped and in that xlsx file those values will become:
value = 10/4/2016, format = 10/4/2016 (still dd/mm/yyyy)
value = 15/03/2017, format = 15/03/2017
I'm in the australian windows locale. How can I fix this so my VBA code does what I expect it to do.
I would try setting local to true, this should keep the date in the desired format. In your code this would look like this:
fileNameXLSX = "H:\20160930.xlsb"
fileNameCSV = "H:\20160930.csv"
Set srcBook = Application.Workbooks.Open(filenameCSV, ReadOnly:=True)
Application.DisplayAlerts = False
srcBook.SaveAs filename:=fileNameXLSX, FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False, Local:=True
srcBook.Close False
Set srcBook = Nothing
Application.DisplayAlerts = True
Source: https://msdn.microsoft.com/en-us/library/office/ff841185.aspx
I would recommend to set the Local parameter to True in the Open command if the dates in the csv are not American.
fileNameXLSB = "H:\20160930.xlsb"
fileNameCSV = "H:\20160930.csv"
Set srcBook = Application.Workbooks.Open(filenameCSV, ReadOnly:=True, local:=True)
Application.DisplayAlerts = False
srcBook.SaveAs Filename:=fileNameXLSB, FileFormat:=xlExcel12, CreateBackup:=False
srcBook.Close False
Set srcBook = Nothing
Application.DisplayAlerts = True
I would recommend as a simple solution to add a line of code that selects the column with the dates in it and sets their number format to the convention you prefer- this would look something like this:
fileNameXLSX = "H:\20160930.xlsb"
filenameCSV = "H:\20160930.csv"
Set srcBook = Application.Workbooks.Open(filenameCSV, ReadOnly:=True)
Application.DisplayAlerts = False
srcBook.SaveAs Filename:=fileNameXLSX, FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False
srcBook.Sheets(1).Columns("A:A").EntireColumn.NumberFormat = "d/mm/yyyy"
srcBook.Close False
Set srcBook = Nothing
Application.DisplayAlerts = True
Hope this helps,
TheSilkCode
I had this same issue, it was the 2nd option to fix for me, local = True must be set when opening the file, not when saving it
(Sorry can't add comments yet)
Related
Excel VBA - Running a Macro against all files in a folder [duplicate]
I have a folder where I receive 1000+ excel files on daily bases they all are same format and structure. What I want to do is run a macro on all 100+ files on daily bases ? Is there way to automate this ? So I can keep running that same macro on 1000+ files daily.
Assuming that you put your files in "Files" directory relative to your master workbook your code might look like this:
Sub ProcessFiles()
Dim Filename, Pathname As String
Dim wb As Workbook
Pathname = ActiveWorkbook.Path & "\Files\"
Filename = Dir(Pathname & "*.xls")
Do While Filename <> ""
Set wb = Workbooks.Open(Pathname & Filename)
DoWork wb
wb.Close SaveChanges:=True
Filename = Dir()
Loop
End Sub
Sub DoWork(wb As Workbook)
With wb
'Do your work here
.Worksheets(1).Range("A1").Value = "Hello World!"
End With
End Sub
In this example DoWork() is your macro that you apply to all of your files. Make sure that you do all your processing in your macro is always in the context of the wb (currently opened workbook).
Disclaimer: all possible error handling skipped for brevity.
A part of the question might be how do I run this on 1000 files?... Do I have to add this macro to all 1000 workbooks? One way to do this is to add your macro's centrally to the file PERSONAL.XLSB (sometimes the extension might be different). This file will be loaded in the background every time you start Excel and makes your macro's available at any time. Initially the PERSONAL.XLSB file will NOT be there. To automatically create this file, just start recording a "dummy" macro (with the record button on the left-bottom of a spreadsheet) and select "Personal Macro Workbook" to store it in. After recording your macro, you can open the VBA editor with Alt+F11 and you will see the PERSONAL.XLSB file with the "dummy" recorded macro. I use this file to store loads of general macro's which are always available, independent of which .xlsx file I have open. I have added these macro's to my own menu ribbon. One disadvantage of this common macro file is that if you launch more than one instance of Excel, you will get an error message that the PERSONAL.XLSB file is already in use by Excel instance Nr. 1. This is no problem as long as you do not add new macro's at this moment.
Thank you very much for this
Sub ProcessFiles()
Dim Filename, Pathname As String
Dim wb As Workbook
Pathname = ActiveWorkbook.Path & "C:\Users\jkatanan\Desktop\20170206Glidepath\V37\"
Filename = Dir(Pathname & "*.xls")
Do While Filename <> ""
Set wb = Workbooks.Open(Pathname & Filename)
BSAQmacro wb
wb.Close SaveChanges:=True
Filename = Dir()
Loop
End Sub
Sub DoWork(wb As Workbook)
With wb
'Do your work here
.Worksheets(1).Range("A1").Value = "Hello World!"
End With
End Sub
Sub ProcessFiles()
Dim Filename, Pathname As String
Dim wb As Workbook
Pathname = ActiveWorkbook.Path & "\C:\Users\20098323\Desktop\EXCL\"
Filename = Dir(Pathname & "*.xlsx")
Do While Filename <> ""
Set wb = Workbooks.Open(Pathname & Filename)
DoWork wb
wb.Close SaveChanges:=True
Filename = Dir()
Loop
End Sub
Sub DoWork(wb As Workbook)
With wb
'Do your work here
.Worksheets(1).Range("A1").Value = "Hello World!"
End With
End Sub
While running this code its showing bad file name or number.
i have stored my all file in ("\C:\Users\20098323\Desktop\EXCL\") EXCL folder
Instead of passing the values to DoWork one can also run the jobs in Processfiles(). Sub ProcessFiles() Dim Filename, Pathname As String Dim wb1 As Workbook Dim wb2 As Workbook Dim Sheet As Worksheet Dim PasteStart As Range Dim Counter As Integer Set wb1 = ActiveWorkbook Set PasteStart = [RRimport!A1] Pathname = ActiveWorkbook.Path & "\For Macro to run\" Filename = Dir(Pathname & "*.xls") Do While Filename <> "" Set wb2 = Workbooks.Open(Pathname & Filename) For Each Sheet In wb2.Sheets With Sheet.UsedRange .Copy PasteStart Set PasteStart = PasteStart.Offset(.Rows.Count) End With Next Sheet wb2.Close Filename = Dir() Loop End Sub
This isn't an exact answer to the question, since I was just trying to run a single script on any file that I opened and couldn't get that to work, but I thought this might help others like me. It worked once I moved the code into a Module in the Visual Basic for Applications dialog box (go to "Insert" then "Module"). Once I added my VBA code to a module, I was able to open any other file in Excel (even a CSV file) and go to Macros, and run the Macro from the other file (that contains the Module with the code) on the file that I had open.
Thanks Peterm!!
Actually, I did my macro using exactly the same code you posted (process_fiels and dowork).
It worked brilliant!! (before my question)
Each of my 1000 workbooks has 84 worksheets. My own macro (which finally works!) splits each workbook into 85 different files (the original + a short version of each worksheet saved as an individual file).
That leaves me with 1000 files + 1000x85 in the same folder, and that would be really hard to sort out.
What I really need is for Process_Files to take the first file, create a folder with the name of the first file, move the first file to the folder with ist name, then run my macro (in the folder named after the first file in the newly created folder...), go back and take the second file, create a folder with the name of the second file, move the second file to the folder with ist name, then run my macro (in the folder named after the second file in the newly created folder...), etc...
At the end, I should have moved all files into folders with the same name as the files, and the contents of the original \Files\ folder would be 1000 folders with the name of the original files, containgin the original files + 84 files which my own macro already does.
Maybe it is easier with the code:
Sub ProcessFiles()
Dim Filename, Pathname As String
Dim wb As Workbook
Pathname = ActiveWorkbook.Path & "\Files\"
Filename = Dir(Pathname & "*.xls")
Do While Filename <> ""
(Here, it should read the file name, create a folder with the file name, move the file into this newly created folder)
Set wb = Workbooks.Open(Pathname & Filename) <- open file, just as is.
DoWork wb <- do my macro,just as is
wb.Close SaveChanges:=False <- not save, to keep the original file
(go back to the original \Files\ folder)
Filename = Dir() <- Next file, just as is
Loop
End Sub
Sub DoWork(wb As Workbook)
With wb
MyMacro
End With
End Sub
Many thanks, this site is great!
__________________edit, the macro now works _________________________
As you can see, I am no VBA expert, but the macro finally works. The code is not neat at all, I am no SW programmer.
Here it is, it might help some one some day.
Sub ProcessFiles_All()
Dim Filename, Pathname, NewPath, FileSource, FileDestination As String
Dim wb As Workbook
Pathname = ActiveWorkbook.Path & "\Files\"
Filename = Dir(Pathname & "*.csv")
Do While Filename <> ""
NewPath = Pathname & Left(Filename, 34) & "\"
On Error Resume Next
MkDir (NewPath)
On Error GoTo 0
Set wb = Workbooks.Open(Pathname & Filename)
DoWorkPlease wb ' <------------ It is important to say please!!
On Error Resume Next
wb.Close SaveChanges:=False
if Err.Number <> 0 then
‘Error handler needed here
End if
Filename = Dir()
Loop
End Sub
Sub DoWorkPlease(wb As Workbook)
With wb
‘ Since my application has over 1800 cells for each column and it is time consuming
‘ I use a “testing mode” were I only play with 18 values.
Dim TestingMode As Integer
Dim ThisRange(1 To 4) As Variant
TestingMode = 0
If TestingMode = 1 Then
ThisRange(1) = "B2:CG18"
ThisRange(2) = "CT2:CT18"
ThisRange(3) = "CH2:CN18"
ThisRange(4) = "CN2:CS18"
Rows("19:18201").Select
Selection.Delete Shift:=xlUp
End If
If TestingMode = 0 Then
ThisRange(1) = "B2:CG18201"
ThisRange(2) = "CT2:CT18201"
ThisRange(3) = "CH2:CN18201"
ThisRange(4) = "CN2:CS18201"
End If
‘ speed up the macro, turn off updating and alerts
Application.ScreenUpdating = False
Application.DisplayAlerts = False
‘ Here is my code that manipulates the cell values from digits (values read by sensors need to be “translated” into real world values. Code not here actually.
‘Then I copy the whole thing into just numbers, there are no longer formulas, easier to work this way.
'_____________________________________
'Get just values - no more formulas
Sheets.Add After:=Sheets(Sheets.Count)
Sheets("Sheet1").Select
Columns("A:CT").Select
Selection.Copy
Sheets("Sheet2").Select
Columns("A:A").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Application.CutCopyMode = False
Selection.NumberFormat = "0"
With Selection
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlBottom
.WrapText = False
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
End With
‘ Then I save this new workbook into a folder with its own name (and under the folder \FILES\
'_____________________________________
'Save the work under its own folder
Dim CleanName, CleanPath, CleanNewName As Variant
CleanPath = ActiveWorkbook.Path
CleanName = ActiveWorkbook.Name
CleanName = Left(CleanName, 34) ‘I take out the extension
CleanPath = CleanPath + "\" + CleanName
CleanNewName = CleanPath + "\" + CleanName
CleanNewName = CleanNewName + "_clean.csv" ‘ and I add “clean” to have a different name now.
On Error Resume Next
ActiveWorkbook.SaveAs Filename:=CleanNewName, FileFormat:=xlCSV, CreateBackup:=False
‘If there is an error I create an empty folder with the name of the file to know which file needs rework.
If Err.Number <> 0 Then
MkDir (CleanPath + "_error_" + CleanName)
End If
'Resume Next
ActiveSheet.Move _
After:=ActiveWorkbook.Sheets(1)
‘ Then I split the workbook into individual files with the data I need for individual sensors.
‘ Here are the individual ranges I need for each file. Since I have over 1000 files, it is worth the effort.
'_______________ the Split!!______________________________
Dim Col(1 To 98) As Variant
Col(1) = "A:A,B:B,CH:CH,CN:CN,CT:CT"
Col(2) = "A:A,C:C,CH:CH,CN:CN,CT:CT"
Col(3) = "A:A,D:D,CH:CH,CN:CN,CT:CT"
Col(4) = "A:A,E:E,CH:CH,CN:CN,CT:CT"
Col(5) = "A:A,F:F,CH:CH,CN:CN,CT:CT"
Col(6) = "A:A,G:G,CH:CH,CN:CN,CT:CT"
Col(7) = "A:A,H:H,CH:CH,CN:CN,CT:CT"
Col(8) = "A:A,I:I,CH:CH,CN:CN,CT:CT"
Col(9) = "A:A,J:J,CH:CH,CN:CN,CT:CT"
Col(10) = "A:A,K:K,CH:CH,CN:CN,CT:CT"
Col(11) = "A:A,L:L,CH:CH,CN:CN,CT:CT"
Col(12) = "A:A,M:M,CH:CH,CN:CN,CT:CT"
Col(13) = "A:A,N:N,CH:CH,CN:CN,CT:CT"
Col(14) = "A:A,O:O,CH:CH,CN:CN,CT:CT"
Col(15) = "A:A,P:P,CI:CI,CO:CO,CT:CT"
Col(16) = "A:A,Q:Q,CI:CI,CO:CO,CT:CT"
Col(17) = "A:A,R:R,CI:CI,CO:CO,CT:CT"
Col(18) = "A:A,S:S,CI:CI,CO:CO,CT:CT"
Col(19) = "A:A,T:T,CI:CI,CO:CO,CT:CT"
Col(20) = "A:A,U:U,CI:CI,CO:CO,CT:CT"
Col(21) = "A:A,V:V,CI:CI,CO:CO,CT:CT"
Col(22) = "A:A,W:W,CI:CI,CO:CO,CT:CT"
Col(23) = "A:A,X:X,CI:CI,CO:CO,CT:CT"
Col(24) = "A:A,Y:Y,CI:CI,CO:CO,CT:CT"
Col(25) = "A:A,Z:Z,CI:CI,CO:CO,CT:CT"
Col(26) = "A:A,AA:AA,CI:CI,CO:CO,CT:CT"
Col(27) = "A:A,AB:AB,CI:CI,CO:CO,CT:CT"
Col(28) = "A:A,AC:AC,CI:CI,CO:CO,CT:CT"
Col(29) = "A:A,AD:AD,CJ:CJ,CP:CP,CT:CT"
Col(30) = "A:A,AE:AE,CJ:CJ,CP:CP,CT:CT"
Col(31) = "A:A,AF:AF,CJ:CJ,CP:CP,CT:CT"
Col(32) = "A:A,AG:AG,CJ:CJ,CP:CP,CT:CT"
Col(33) = "A:A,AH:AH,CJ:CJ,CP:CP,CT:CT"
Col(34) = "A:A,AI:AI,CJ:CJ,CP:CP,CT:CT"
Col(35) = "A:A,AJ:AJ,CJ:CJ,CP:CP,CT:CT"
Col(36) = "A:A,AK:AK,CJ:CJ,CP:CP,CT:CT"
Col(37) = "A:A,AL:AL,CJ:CJ,CP:CP,CT:CT"
Col(38) = "A:A,AM:AM,CJ:CJ,CP:CP,CT:CT"
Col(39) = "A:A,AN:AN,CJ:CJ,CP:CP,CT:CT"
Col(40) = "A:A,AO:AO,CJ:CJ,CP:CP,CT:CT"
Col(41) = "A:A,AP:AP,CJ:CJ,CP:CP,CT:CT"
Col(42) = "A:A,AQ:AQ,CJ:CJ,CP:CP,CT:CT"
Col(43) = "A:A,AR:AR,CK:CK,CQ:CQ,CT:CT"
Col(44) = "A:A,AS:AS,CK:CK,CQ:CQ,CT:CT"
Col(45) = "A:A,AT:AT,CK:CK,CQ:CQ,CT:CT"
Col(46) = "A:A,AU:AU,CK:CK,CQ:CQ,CT:CT"
Col(47) = "A:A,AV:AV,CK:CK,CQ:CQ,CT:CT"
Col(48) = "A:A,AW:AW,CK:CK,CQ:CQ,CT:CT"
Col(49) = "A:A,AX:AX,CK:CK,CQ:CQ,CT:CT"
Col(50) = "A:A,AY:AY,CK:CK,CQ:CQ,CT:CT"
Col(51) = "A:A,AZ:AZ,CK:CK,CQ:CQ,CT:CT"
Col(52) = "A:A,BA:BA,CK:CK,CQ:CQ,CT:CT"
Col(53) = "A:A,BB:BB,CK:CK,CQ:CQ,CT:CT"
Col(54) = "A:A,BC:BC,CK:CK,CQ:CQ,CT:CT"
Col(55) = "A:A,BD:BD,CK:CK,CQ:CQ,CT:CT"
Col(56) = "A:A,BE:BE,CK:CK,CQ:CQ,CT:CT"
Col(57) = "A:A,BF:BF,CL:CL,CR:CR,CT:CT"
Col(58) = "A:A,BG:BG,CL:CL,CR:CR,CT:CT"
Col(59) = "A:A,BH:BH,CL:CL,CR:CR,CT:CT"
Col(60) = "A:A,BI:BI,CL:CL,CR:CR,CT:CT"
Col(61) = "A:A,BJ:BJ,CL:CL,CR:CR,CT:CT"
Col(62) = "A:A,BK:BK,CL:CL,CR:CR,CT:CT"
Col(63) = "A:A,BL:BL,CL:CL,CR:CR,CT:CT"
Col(64) = "A:A,BM:BM,CL:CL,CR:CR,CT:CT"
Col(65) = "A:A,BN:BN,CL:CL,CR:CR,CT:CT"
Col(66) = "A:A,BO:BO,CL:CL,CR:CR,CT:CT"
Col(67) = "A:A,BP:BP,CL:CL,CR:CR,CT:CT"
Col(68) = "A:A,BQ:BQ,CL:CL,CR:CR,CT:CT"
Col(69) = "A:A,BR:BR,CL:CL,CR:CR,CT:CT"
Col(70) = "A:A,BS:BS,CL:CL,CR:CR,CT:CT"
Col(71) = "A:A,BT:BT,CM:CM,CS:CS,CT:CT"
Col(72) = "A:A,BU:BU,CM:CM,CS:CS,CT:CT"
Col(73) = "A:A,BV:BV,CM:CM,CS:CS,CT:CT"
Col(74) = "A:A,BW:BW,CM:CM,CS:CS,CT:CT"
Col(75) = "A:A,BX:BX,CM:CM,CS:CS,CT:CT"
Col(76) = "A:A,BY:BY,CM:CM,CS:CS,CT:CT"
Col(77) = "A:A,BZ:BZ,CM:CM,CS:CS,CT:CT"
Col(78) = "A:A,CA:CA,CM:CM,CS:CS,CT:CT"
Col(79) = "A:A,CB:CB,CM:CM,CS:CS,CT:CT"
Col(80) = "A:A,CC:CC,CM:CM,CS:CS,CT:CT"
Col(81) = "A:A,CD:CD,CM:CM,CS:CS,CT:CT"
Col(82) = "A:A,CE:CE,CM:CM,CS:CS,CT:CT"
Col(83) = "A:A,CF:CF,CM:CM,CS:CS,CT:CT"
Col(84) = "A:A,CG:CG,CM:CM,CS:CS,CT:CT"
‘ I want to split 84 new files, so for testing I use only 1, and for the real thing I go with 84
Dim CounterMode As Integer
If TestingMode = 1 Then CounterMode = 1 Else CounterMode = 84
For i = 1 To CounterMode
‘ this code takes the columns need, and paste it into a new workbook.
Sheets("Sheet1").Select
Cells.Select
Selection.ClearContents
Range("A1").Activate
Sheets(2).Select
Range(Col(i)).Select
Selection.Copy
Sheets("Sheet1").Select
ActiveSheet.Paste
Application.CutCopyMode = False
With Selection
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlBottom
.WrapText = False
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
End With
Columns("A:E").EntireColumn.AutoFit
‘ Save the individual file
'_____________save the work________________
Dim ThePath, TheName, TheSwitch As String
ThePath = ActiveWorkbook.Path + “\”
TheName = Left(ActiveWorkbook.Name, 34) ‘ take out the extension from the name
ThePath = ThePath + TheName
TheSwitch = Cells(3, 2) ‘ In Cell (3,2) I have the name of the individual name, so I added to the file name.
TheName = ThePath + "_" + TheSwitch + ".xls"
Range("A1").Select
Sheets("Sheet1").Select
Sheets("Sheet1").Copy
Dim SheetName As Variant
‘ I name Sheets(1) as Sheet1, since the original sheet has the name and date of the test.
‘ I do this to have the same name on all file in order to do a plot, then I rename the sheet with the
‘ original name
SheetName = ActiveSheet.Name
ActiveWorkbook.Sheets(1).Name = "Sheet1"
‘ here is the plot
Columns("A:E").EntireColumn.AutoFit
Columns("B:E").Select
ActiveSheet.Shapes.AddChart.Select
ActiveChart.SetSourceData Source:=Range("'Sheet1'!$B:$E")
ActiveChart.ChartType = xlXYScatterLinesNoMarkers
ActiveWorkbook.Sheets(1).Name = SheetName
‘save
On Error Resume Next
ActiveWorkbook.SaveAs Filename:=TheName, FileFormat:=56, CreateBackup:=False
If Err.Number <> 0 Then
MkDir (ThePath + "_error_" + TheName)
End If
ActiveWorkbook.Close
Next i
'____________________That was the Split__________________________________
' Turn on screenupdating:
Application.ScreenUpdating = True
Application.DisplayAlerts = True
Range("A1").Select
End With
End Sub
VBA - Application.DisplayAlerts = False not working
This is intended to be a daily macro that run to update a report. This file would need to overwrite the existing file daily. However, the Application.DisplayAlerts = False is not working and I still get the pop up saying that this file already exists and if I want to replace. Is there something wrong with my code or is there a workaround to use a method that would automatically click yes for me?
Sub DailyRefresh ()
'Open and refresh Access
Dim appAccess As Object
Set appAccess = GetObject("S:\Shared\DailyRefresh.accdb")
Application.DisplayAlerts = False
appAccess.Visible = True
appAccess.DoCmd.RunMacro "Run_All_Queries"
appAccess.CloseCurrentDatabase
'Open Excel
Set xl = CreateObject("Excel.Application")
xl.Workbooks.Open ("s:\Shared\Template.xlsx")
xl.Visible = True
Application.DisplayAlerts = False
'Set date to the 1st of the Month on Summary tab
xl.Sheets("Summary").Visible = True
xl.Sheets("Summary").Select
xl.Range("C10").Value = DateSerial(Year(Now), Month(Now), 1)
xl.Range("C10").NumberFormat = "mm/dd/yyyy"
' REFRESH Table
xl.Sheets("Data").Visible = True
xl.Sheets("Data").Select
xl.Range("A1").Select
xl.Range("DailyRefresh.accdb[[#Headers],[ACTIVITY_DT]]").Select
xl.Selection.ListObject.QueryTable.Refresh BackgroundQuery:=False
xl.Worksheets("Fname").Visible = True
xl.Sheets("Fname").Select
'Copy and Save AS
Application.DisplayAlerts = False
Path = "S:\Shared\NewTemplate"
Filename = xl.Sheets("Fname").Range("A7").Value
xl.SaveAs Path & Filename & ".xlsx", FileFormat:=51, CreateBackup:=False
xl.Worksheets("Fname").Visible = False
xl.Close
Application.DisplayAlerts = True
End Sub
Application.DisplayAlerts = False refers to the application where your code is running, not the Excel instance you created. xl.DisplayAlerts = False would be what you want.
I propose you to use Application.DisplayAlerts = False exactly before the line(s) that are taking time (no other lines between them). I had the same problem, because I was using it just once, but after each line that calls an external app, when it is back to VBA, it goes back to true.
Bringing data from other workbooks - goal not accomplished in nested if
I have this code in which I am bringing data from several workbooks into one. The data of each workbook needs to be added into a specific range depending on the source. To do this I nested some IFs with the partial name of the file as condition and giving the action of sending the values to the desired range, but when I run the code it only opens all the workbooks without performing any action. I already did some research and did not find anything to help me with my problem
Sub Update_Database()
Dim directory As String
Dim fileName As String
Application.ScreenUpdating = False
With Application.FileDialog(msoFileDialogFolderPicker)
.AllowMultiSelect = False
.Show
directory = .SelectedItems(1)
Err.Clear
End With
fileName = Dir(directory & "\", vbReadOnly)
Dim mwb As Workbook
Set mwb = Workbooks("OEE_Database_Final.xlsm")
Do While fileName <> ""
On Error GoTo ProcExit
With Workbooks.Open(fileName:=directory & "\" & fileName, UpdateLinks:=False, ReadOnly:=True)
If (fileName = "NOM*.xlsx") Then
ActiveWorkbook.Sheets("Database").Range("O9:Z290").Value = mwb.Sheets("Database").Range("O9:Z290")
ActiveWorkbook.Close SaveChanges:=False
ElseIf (fileName = "SZE*.xlsx") Then
ActiveWorkbook.Sheets("Database").Range("O291:Z537").Value = mwb.Sheets("Database").Range("O291:Z537")
ActiveWorkbook.Close SaveChanges:=False
ElseIf (fileName = "VEC*.xlsx") Then
ActiveWorkbook.Sheets("Database").Range("O538:Z600").Value = mwb.Sheets("Database").Range("O538:Z600")
ActiveWorkbook.Close SaveChanges:=False
ElseIf (fileName = "KAY*.xlsx") Then
ActiveWorkbook.Sheets("Database").Range("O601:Z809").Value = mwb.Sheets("Database").Range("O601:Z809")
ActiveWorkbook.Close SaveChanges:=False
ElseIf (fileName = "BBL*.xlsx") Then
ActiveWorkbook.Sheets("Database").Range("O810:Z952").Value = mwb.Sheets("Database").Range("O810:Z952")
ActiveWorkbook.Close SaveChanges:=False
ElseIf (fileName = "POG*.xlsx") Then
ActiveWorkbook.Sheets("Database").Range("O953:Z1037").Value = mwb.Sheets("Database").Range("O953:Z1037")
ActiveWorkbook.Close SaveChanges:=False
ElseIf (fileName = "SC1*.xlsx") Then
ActiveWorkbook.Sheets("Database").Range("O1038:Z1159").Value = mwb.Sheets("Database").Range("O1038:Z1159")
ActiveWorkbook.Close SaveChanges:=False
ElseIf (fileName = "SC2*.xlsx") Then
ActiveWorkbook.Sheets("Database").Range("O1160:Z1200").Value = mwb.Sheets("Database").Range("O1160:Z1200")
ActiveWorkbook.Close SaveChanges:=False
ElseIf (fileName = "SLP*.xlsx") Then
ActiveWorkbook.Sheets("Database").Range("O1201:Z1263").Value = mwb.Sheets("Database").Range("O1201:Z1263")
ActiveWorkbook.Close SaveChanges:=False
ElseIf (fileName = "UIT*.xlsx") Then
ActiveWorkbook.Sheets("Database").Range("O1264:Z1348").Value = mwb.Sheets("Database").Range("O1264:Z1348")
ActiveWorkbook.Close SaveChanges:=False
ElseIf (fileName = "ANE*.xlsx") Then
ActiveWorkbook.Sheets("Database").Range("O1349:Z1823").Value = mwb.Sheets("Database").Range("O1349:Z1823")
ActiveWorkbook.Close SaveChanges:=False
ElseIf (fileName = "HAL*.xlsx") Then
ActiveWorkbook.Sheets("Database").Range("O1824:Z2077").Value = mwb.Sheets("Database").Range("O1824:Z2077")
ActiveWorkbook.Close SaveChanges:=False
ElseIf (fileName = "SHX*.xlsx") Then
ActiveWorkbook.Sheets("Database").Range("O2078:Z2242").Value = mwb.Sheets("Database").Range("O2078:Z2242")
ActiveWorkbook.Close SaveChanges:=False
ElseIf (fileName = "BAY*.xlsx") Then
ActiveWorkbook.Sheets("Database").Range("O2243:Z2415").Value = mwb.Sheets("Database").Range("O2243:Z2415")
ActiveWorkbook.Close SaveChanges:=False
ElseIf (fileName = "TAM*.xlsx") Then
ActiveWorkbook.Sheets("Database").Range("O2416:Z2522").Value = mwb.Sheets("Database").Range("O2416:Z2522")
ActiveWorkbook.Close SaveChanges:=False
ElseIf (fileName = "PUC*.xlsx") Then
ActiveWorkbook.Sheets("Database").Range("O2523:Z2607").Value = mwb.Sheets("Database").Range("O2523:Z2607")
ActiveWorkbook.Close SaveChanges:=False
ElseIf (fileName = "JOF*.xlsx") Then
ActiveWorkbook.Sheets("Database").Range("O2608:Z2648").Value = mwb.Sheets("Database").Range("O2608:Z2648")
ActiveWorkbook.Close SaveChanges:=False
ElseIf (fileName = "MAV*.xlsx") Then
ActiveWorkbook.Sheets("Database").Range("O2649:Z2945").Value = mwb.Sheets("Database").Range("O2649:Z2945")
ActiveWorkbook.Close SaveChanges:=False
End If
End With
fileName = Dir
Loop
Application.ScreenUpdating = True
ProcExit:
Exit Sub
End Sub
You can "cheat" a little to get away with Select Case. In order to use the Like with Select, you use Select Case True and then nest your scenraios using Like and wild card *. code With Workbooks.Open(Filename:=directory & "\" & Filename, UpdateLinks:=False, ReadOnly:=True) Select Case True Case Filename Like "NOM*.xlsx" Case Filename Like "SZE*.xlsx" Case Filename Like "VEC*.xlsx" Case Filename Like "KAY*.xlsx" Case Filename Like "BBL*.xlsx" ' put all other scenarios down here.... End Select End With Note: if all your files you are trying t check are excel files, so you don't need to add the .xlsx extension, just use NOM*, SZE*, etc.
Given the snippet
With Workbooks.Open(fileName:=directory & "\" & fileName, UpdateLinks:=False, ReadOnly:=True)
If (fileName = "NOM*.xlsx") Then
ActiveWorkbook.Sheets("Database").Range("O9:Z290").Value = mwb.Sheets("Database").Range("O9:Z290")
ActiveWorkbook.Close SaveChanges:=False
End If
End With
you're opening a file, writing some values from mbw.Sheets("Database") to it and then close the just modified file without saving.
From your comment it seems your intention is to do the opposite:
Dim mwb As Workbook
Set mwb = Workbooks("OEE_Database_Final.xlsm")
Dim Ws As Worksheet
Set Ws = mwb.Sheets("Database")
Do While Filename <> ""
On Error GoTo ProcExit
With Workbooks.Open(Filename:=directory & "\" & Filename, UpdateLinks:=False, ReadOnly:=True)
Select Case True
Case Filename Like "NOM*.xlsx"
Ws.Range("O9:Z290").Value = .Sheets("Database").Range("O9:Z290").Value
.Close SaveChanges:=False
Case Filename Like "SZE*.xlsx"
' Code for this case
' Other cases...
Case Else
' Put code here that is executed if none of the previous names has been matched
' or remove 'Case Else' if you don't want anything to happen then
End Select
End With
Filename = Dir
Loop
Some things to note:
I've implemented the suggestion from Shai Rado's answer to make use of the Like operator in a Select Case structure
I've assigned a new Worksheet variable as such Set Ws = mwb.Sheets("Database") - this shortens the lines and makes it easier to refer to a different sheet, should requirements change (one change as opposed to ~20 changes)
The With block now is actually taken advantage of. When you do With Workbooks.Open, VBA provides you with an implicit reference to that workbook. So there is no need to refer to ActiveWorkbook. A simple . is enough. Also it removes that brittle dependency on having the right workbook active at the right time. (Imagine what happens if for whatever reason the ActiveWorkbook changes half-way through your macro... Not a likely scenario, I'll give you that.)
Read closed .xlsm files as xml files to pull data
I am a new programmer and I am trying to find a way to extract one range of data from multiple workbooks and copy them into a master file. I have already wrote the code to do this below, but the problem that I am having is that my code physically opens the xlsm files > copies the data > then goes back into the master file to paste. Since this is being done to thousands of files at once, it takes hours to complete. My boss told me there is a way to copy the data from the xlsm files without having the code actually open the file if it is read as xml or as a .txt file. I have searched online for this, but cannot find anything on how this would be done. Any help would be greatly appreciated.
The code I have that physically opens the workbooks:
Option Explicit
Sub ReadDataFromCloseFile()
On Error GoTo ErrHandler
Application.EnableEvents = False
Application.ScreenUpdating = False
Dim FileType As String
Dim FilePath As String
FileType = "*.xlsm*" 'The file type to search for
FilePath = "C:\Users\hasib\xlsm's\" 'The folder to search
Dim src As Workbook
Dim OutputCol As Variant
Dim Curr_File As Variant
OutputCol = 9 'The first row of the active sheet to start writing to
Curr_File = Dir(FilePath & FileType)
Do Until Curr_File = ""
' OPEN THE SOURCE EXCEL WORKBOOK IN "READ ONLY MODE".
Set src = Workbooks.Open(FilePath & Curr_File, True, True)
Sheets("Reporting").Range("I7:I750").Copy
Workbooks("Master.xlsm").Activate
Sheets("Sheet2").Select
Sheets("Sheet2").Cells(4, OutputCol).Select
ActiveCell.PasteSpecial Paste:=xlPasteValuesAndNumberFormats
Application.CutCopyMode = False
OutputCol = OutputCol + 1
' CLOSE THE SOURCE FILE.
src.Close False ' FALSE - DON'T SAVE THE SOURCE FILE.
Curr_File = Dir
Loop
Set src = Nothing
Application.EnableEvents = True
Application.ScreenUpdating = True
ErrHandler:
Application.EnableEvents = True
Application.ScreenUpdating = True
End Sub
I found out that there is a formula you can use in a cell that will pull in data from a closed workbook. If you type ='folderpath[filename]Sheetname'Cell into a cell it will automatically pull in that information. Using this logic I created the below to loop through all my files and paste data into my workbook from the files being called:
Set fd = Application.FileDialog(msoFileDialogFilePicker)
fd.InitialFileName = "c:\"
fd.InitialView = msoFileDialogViewList
fd.AllowMultiSelect = True
FileChosen = fd.Show
FilePath = fd.SelectedItems(1)
FolderPath = Left(FilePath, InStrRev(FilePath, "\"))
If FileChosen = -1 Then
'open each of the files chosen
For c = 1 To fd.SelectedItems.count
FileName = Dir(fd.SelectedItems(c))
ThisWorkbook.Sheets("Batch Results").Cells(OutputRow, OutputCol).Formula = "='" & FolderPath & "[" & FileName & "]Reporting'!$I7"
OutputCol = OutputCol + 1
Next c
End If
ThisWorkbook.Sheets("Batch Results").Select
Cells(1, OutputCol).Select
EndColumn = Split(ActiveCell(1).Address(1, 0), "$")(0)
RangeName = ("A1:" & EndColumn & "1")
Range(RangeName).Select
Selection.AutoFill Destination:=Range("A1:" & EndColumn & "558"), Type:=xlFillDefualt
Import 150 text files to Access as Tables using SQL
I have 150 text files in csv format using pipe | as a seperator. the files are in different folders on a network. The filenames are date specific and have a suffix which holds the date. I have created a table which has 3 fields: File Location; File Name excluding suffix; suffix (in format yymmdd). I want to create an SQL script which will import each of the 150 files named in the table that I have created into 150 seperate Access 2007 tables named as the File Name excluding Suffix. I tried to do this using VBA but the filenames contain full stops and VBA didn't like this. Each of the files has a different column structure but the first row is always headers. I can only use Features native to Access 2007 as the organisation I work for does not allow third party addons or applications. I don't have SQL server available to me. I am a complete novice when it comes to Access and am struggling to achieve anything approaching this. Can you help?
I struggled to achieve what I wanted in Access and so went over to Excel instead. The code below creates each of the text files as a sheet within a single Excel workbook with the Master table holding the filename / path etc as a "Master" Sheet within the workbook. It deletes all of the sheets other than "Master" before recreating them and if a file is not found it will leave a blank sheet.
Sub ImportFiles()
'This script looks at a Master list of files for import and imports each to their own tab
'The files are pipe (|) delimited and can be in any addressable location
'If any files are not found, the import of that file is skipped, leaving a blank worksheet
'Close the Report File before starting the import
Application.DisplayAlerts = False
On Error Resume Next
Windows("Report.xlsx").Activate
Windows("Report.xlsx").Close SaveChanges:=True
On Error GoTo 0
Application.DisplayAlerts = True
'Start by looking at the sheet which contains the Master list of files
Sheets("Master").Activate
'declare three arrays of unknown length
Dim FileName() As String
Dim FilePath() As String
Dim FullName() As String
'initially there are no files
Dim NumberFiles As Integer
NumberFiles = 0
'loop over all of the file cells
'The master file needs to be structured FileName, FilePath and FullName in that order
'Change C2 to the cell containing the first FileName in the Master List
Dim FileCell As Range
Dim TopCell As Range
Dim FileRange As Range
Set TopCell = Range("C2")
Set FileRange = Range(TopCell, TopCell.End(xlDown))
For Each FileCell In FileRange
'we've found another file!
NumberFiles = NumberFiles + 1
'for each file found, extend all arrays
ReDim Preserve FileName(NumberFiles - 1)
ReDim Preserve FilePath(NumberFiles - 1)
ReDim Preserve FullName(NumberFiles - 1)
'now store the filename, path and fullname of the new file
FileName(NumberFiles - 1) = FileCell.Value
FilePath(NumberFiles - 1) = FileCell.Offset(0, 1).Value
FullName(NumberFiles - 1) = FileCell.Offset(0, 2).Value
Next FileCell
'delete any existing sheets except Master and create new blank sheets
For Each Sheet In Application.Worksheets
Application.DisplayAlerts = False
If Sheet.Name <> "Master" Then
Sheet.Delete
End If
Next Sheet
Sheets("Master").Activate
For i = 1 To (NumberFiles)
Worksheets.Add(After:=Sheets(Sheets.Count)).Name = "Sheet" & i
Next i
ThisWorkbook.Sheets("Sheet1").Select
'Start the process of import
'create a workbook object for the workbook where the current macro is running
Dim ws As Worksheet
'import each file into its own sheet
For i = 0 To (NumberFiles - 1)
Set ws = ThisWorkbook.Sheets("Sheet" & i + 1) 'the current sheet
'Ignore any missing files and carry on processing
Application.DisplayAlerts = False
On Error Resume Next
'This imports the delimited files
With ws.QueryTables.Add(Connection:="TEXT;" & FullName(i), Destination:=ws.Range("$A$1"))
.Name = "a" & i
.FieldNames = True
.RowNumbers = False
.FillAdjacentFormulas = False
.PreserveFormatting = True
.RefreshOnFileOpen = False
.RefreshStyle = xlInsertDeleteCells
.SavePassword = False
.SaveData = True
.AdjustColumnWidth = True
.RefreshPeriod = 0
.TextFilePromptOnRefresh = False
.TextFilePlatform = 850
.TextFileStartRow = 1
.TextFileParseType = xlDelimited
.TextFileTextQualifier = xlTextQualifierDoubleQuote
.TextFileConsecutiveDelimiter = False
.TextFileTabDelimiter = True
.TextFileSemicolonDelimiter = False
.TextFileCommaDelimiter = False
.TextFileSpaceDelimiter = False
.TextFileOtherDelimiter = "|"
.TextFileColumnDataTypes = Array(1, 1, 1)
.TextFileTrailingMinusNumbers = True
.Refresh BackgroundQuery:=False
End With
'Rename tabs to name on master list
ws.Name = "" & FileName(i)
Next i
'Reopen the Report File
Workbooks.Open FileName:=ThisWorkbook.Path & "\Report.xlsx"
End Sub