I have txt files that are automatically exported to me from another system (I cannot change this system). When I try to convert these txt files to excel with the following code (I created a subfolder xlsx manually):
Sub all()
Dim sourcepath As String
Dim sDir As String
Dim newpath As String
sourcepath = "C:\Users\PC\Desktop\Test\"
newpath = sourcepath & "xlsx\"
'make sure subfolder xlsx was created before
sDir = Dir$(sourcepath & "*.txt", vbNormal)
Do Until Len(sDir) = 0
Workbooks.Open (sourcepath & sDir)
With ActiveWorkbook
.SaveAs Filename:=Replace(Left(.FullName, InStrRev(.FullName, ".")), sourcepath, newpath) & "xlsx", FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False
.Close
End With
sDir = Dir$
Loop
End Sub
it does work, however certain special characters, like ä,ö and Ü and so, are not properly displayed. I.e. when I open the xlsx files later on, I can see that these have been replaced by something like ä and so. I could use a work around and now start to replace these afterwards, however I would like to improve my txt to xlsx code. According to this post or this one it should be possible using ADODB.Stream. However, I don't know how to implement this into my code (loop) to get it working here in my case? If there is another approach instead of ADOB.Stream I am also fine with that. It is not necessary for me to use ADOB.Stream.
Have you tried coercing the code page, using the Origin parameter? I don't know if you need a particular one, but the UTF-8 constant might be a starting point. I personally like this page as a reference source: https://learn.microsoft.com/en-us/windows/win32/intl/code-page-identifiers
So the solution might turn out to be as simple as this - it worked in my dummy tests:
Option Explicit
Private Const CP_UTF8 As Long = 65001
Public Sub RunMe()
Dim sDir As String, sourcePath As String, fileName As String
Dim fso As Object
sourcePath = "C:\anyoldpath\"
Set fso = CreateObject("Scripting.FileSystemObject")
sDir = Dir(sourcePath & "*.txt", vbNormal)
Do While Len(sDir) > 0
fileName = sourcePath & "xlsx\" & fso.GetBaseName(sDir) & ".xlsx"
Application.Workbooks.OpenText sourcePath & sDir, CP_UTF8
ActiveWorkbook.SaveAs fileName, xlOpenXMLWorkbook
ActiveWorkbook.Close False
sDir = Dir()
Loop
End Sub
Assuming that these txt files are tab delimited.
The handling of the characters or code page it's managed by the Origin parameter of the Workbooks.OpenText method or by the TextFilePlatform property of the QueryTable object.
These txt files should be opened with Workbooks.OpenText method, however in order to handle problem of the Decimal.Separator been different than then one in your system, I suggest to use the QueryTable method also applied to the tab separated files with a csv extension.
We just need to replace these lines:
sFile = Dir$(sPathSrc & "*.csv")
sFilenameTrg = sPathTrg & Left(sFile, InStrRev(sFile, ".csv")) & "xlsx"
With these:
sFile = Dir$(sPathSrc & "*.txt")
sFilenameTrg = sPathTrg & Left(sFile, InStrRev(sFile, ".txt")) & "xlsx"
No changes to Procedure `Open_Csv_As_Tab_Delimited_Then_Save_As_Xls, perhaps a change in the name to reflect its versatility.
Tested with this tst file:
Generated this `xlsx' file:
Hopefully, it should be straightforward to add these procedure to you project, let me know of any problem or question you might have with the resources used.
Sub Tab_Delimited_UTF8_Files_Save_As_Xlsx()
Dim sFilenameSrc As String, sFilenameTrg As String
Dim sPathSrc As String, sPathTrg As String
Dim sFile As String
Dim bShts As Byte, exCalc As XlCalculation
sPathSrc = "C:\Users\PC\Desktop\Test\"
sPathTrg = sPathSrc & "xlsx\"
Rem Excel Properties OFF
With Application
.EnableEvents = False
.DisplayAlerts = False
.ScreenUpdating = False
exCalc = .Calculation
.Calculation = xlCalculationManual
.CalculateBeforeSave = False
bShts = .SheetsInNewWorkbook
.SheetsInNewWorkbook = 1
End With
Rem Validate Target Folder
If Len(Dir$(sPathTrg, vbDirectory)) = 0 Then MkDir sPathTrg
Rem Process Csv Files
sFile = Dir$(sPathSrc & "*.txt")
Do Until Len(sFile) = 0
sFilenameSrc = sPathSrc & sFile
sFilenameTrg = sPathTrg & Left(sFile, InStrRev(sFile, ".txt")) & "xlsx"
Call Open_Csv_As_Tab_Delimited_Then_Save_As_Xls(sFilenameSrc, sFilenameTrg)
sFile = Dir$
Loop
Rem Excel Properties OFF
With Application
.SheetsInNewWorkbook = bShts
.Calculation = exCalc
.CalculateBeforeSave = True
.ScreenUpdating = True
.DisplayAlerts = True
.EnableEvents = True
End With
End Sub
…
Sub Open_Txt_As_Tab_Delimited_Then_Save_As_Xls(sFilenameSrc As String, sFilenameTrg As String)
Dim Wbk As Workbook
Rem Workbook - Add
Set Wbk = Workbooks.Add(Template:="Workbook")
With Wbk
Rem Txt File - Import
With .Worksheets(1)
Rem QueryTable - Add
With .QueryTables.Add(Connection:="TEXT;" & sFilenameSrc, Destination:=.Cells(1))
Rem QueryTable - Properties
.SaveData = True
.TextFileParseType = xlDelimited
.TextFileDecimalSeparator = "."
.TextFileThousandsSeparator = ","
.TextFileConsecutiveDelimiter = False
.TextFileTabDelimiter = True
.TextFileTrailingMinusNumbers = True
.TextFilePlatform = 65001 'Unicode (UTF-8)
.Refresh BackgroundQuery:=False
Rem QueryTable - Delete
.Delete
End With: End With
Rem Workbook - Save & Close
.SaveAs Filename:=sFilenameTrg, FileFormat:=xlOpenXMLWorkbook
.Close
End With
End Sub
I have tab separated csv files which I want to transform to xlsx. So each csv should be transformed to a xlsx. Filename should be the same. However, the files are tab separated. For example, see this test file screenshot:
When I run my code (I created a subfolder xlsx before):
Sub all()
Dim sourcepath As String
Dim sDir As String
Dim newpath As String
sourcepath = "C:\Users\PC\Desktop\Test\"
newpath = sourcepath & "xlsx\"
'make sure subfolder xlsx was created before
sDir = Dir$(sourcepath & "*.csv", vbNormal)
Do Until Len(sDir) = 0
Workbooks.Open (sourcepath & sDir)
With ActiveWorkbook
.SaveAs Filename:=Replace(Left(.FullName, InStrRev(.FullName, ".")), sourcepath, newpath) & "xlsx", FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False
.Close
End With
sDir = Dir$
Loop
End Sub
it does work, but when I look into the excel file:
I can see that the tab separator was not detected. I think my local settings are that the separator is a semi-colon and that's why it is not working. Now I wanted to set dataType to xlDelimited and tab to True, with changing the one line to:
Workbooks.Open (Spath & sDir), DataType:=xlDelimited, Tab:=True
I also tried
Workbooks.Open (Spath & sDir, DataType:=xlDelimited, Tab:=True)
or
Workbooks.Open FileName:=Spath & sDir, DataType:=xlDelimited, Tab:=True
But this leads to an error message. I then tried another approach, where I set the delimiter to Chr(9) (tab) and local to false:
Sub all()
Dim wb As Workbook
Dim strFile As String
Dim strDir As String
strDir = "C:\Users\PC\Desktop\Test\"
strFile = Dir(strDir & "*.csv")
Do While strFile <> ""
Set wb = Workbooks.Open(Filename:=strDir & strFile, Delimiter:=Chr(9), Local:=False)
With wb
.SaveAs Replace(wb.FullName, ".csv", ".xlsx"), 51
.Close True
End With
Set wb = Nothing
strFile = Dir
Loop
End Sub
It does not lead to an error. But when I open the file, it looks like:
So again same problem, the tab separator is not recognized. How can I fix this?
(I also tried it with local:True together with Delimiter:=Chr(9), but same problem and I also tried it with adding Format:=6)
I tried it this way with csv as I did not want to go the same way with txt file extension. Reason is that using csv easily allows special language characters like "ö" and "ü". So that is why I wanted to convert csv to xlsx and not use the workaround of using txt instead, as I then run into the problem that when I try to convert txt to xlsx certain special characters are not properly recognised and I hope to avoid this problem with using csv.
The csv (or actually these are tsv, because they have the tab as separator and not semi-colon) files have different columns. So could be one csv file has 5 columns, the other 6 and the datatypes vary too.
EDIT:
In repsonse to EEMs answer:
Check this Test.csv file, it looks like this:
Separated by tab. Not semi-colon.
When I run the code (plus adding .TextFileDecimalSeparator = "." to the code) and check the resulting xlsx file it looks like this:
Values in the second column (ColumnÄ), like 9987.5 are correctly transformed to 9987,5. But values in the last column (ColumnI) are wrongly transformed. This is my problem now. (I dont know why special character does not get transformed correctly, as in my original files this does work.)
As mentioned by #RonRosenfeld, files with .csv extension will be opened by excel as a text file with tab delimiters.
Also the following assumption is not accurate:
Option1 txt is not a way for me, as I face a new problem that UTF-8
special characters, like äö and so are not properly imported.
The handling of the characters or code page has nothing to do with the extension of the files, instead it's managed by the Origin parameter of the Workbooks.OpenText method or by the TextFilePlatform property of the QueryTable object.
Therefore unless the files are renamed with a extension different than csv the [Workbooks.OpenText method] will not be effective.
The solution proposed below, uses the QueryTable object and consist of two procedures:
Tab_Delimited_UTF8_Files_Save_As_Xlsx
Sets the source and target folder
Creates the xlsx folder if not present
Gets all csv files in the source folder
Open_Csv_As_Tab_Delimited_Then_Save_As_Xls
Process each csv files
Adds a workbook to hold the Query Table
Imports the csv file
Deletes the Query
Saves the File as `xlsx'
EDIT I These lines were added to ensure the conversion of the numeric data:
.TextFileDecimalSeparator = "."
.TextFileThousandsSeparator = ","
EDIT II A Few changes to rename the worksheet (marked as '# )
Tested with this csv file:
Generated this `xlsx' file:
Hopefully, it should be straightforward to add these procedure to you project, let me know of any problem or question you might have with the resources used.
Sub Tab_Delimited_UTF8_Files_Save_As_Xlsx()
Dim sFile As String
Dim sPathSrc As String, sPathTrg As String
Dim sFilenameSrc As String, sFilenameTrg As String
Dim bShts As Byte, exCalc As XlCalculation
Rem sPathSrc = "C:\Users\PC\Desktop\Test\"
sPathTrg = sPathSrc & "xlsx\"
Rem Excel Properties OFF
With Application
.EnableEvents = False
.DisplayAlerts = False
.ScreenUpdating = False
exCalc = .Calculation
.Calculation = xlCalculationManual
.CalculateBeforeSave = False
bShts = .SheetsInNewWorkbook
.SheetsInNewWorkbook = 1
End With
Rem Validate Target Folder
If Len(Dir$(sPathTrg, vbDirectory)) = 0 Then MkDir sPathTrg
Rem Process Csv Files
sFile = Dir$(sPathSrc & "*.csv")
Do Until Len(sFile) = 0
sFilenameSrc = sPathSrc & sFile
sFile = Left(sFile, -1 + InStrRev(sFile, ".csv")) '#
sFilenameTrg = sPathTrg & sFile & ".xlsx" '#
Call Open_Csv_As_Tab_Delimited_Then_Save_As_Xls(sFile, sFilenameSrc, sFilenameTrg) '#
sFile = Dir$
Loop
Rem Excel Properties OFF
With Application
.SheetsInNewWorkbook = bShts
.Calculation = exCalc
.CalculateBeforeSave = True
.ScreenUpdating = True
.DisplayAlerts = True
.EnableEvents = True
End With
End Sub
…
Sub Open_Csv_As_Tab_Delimited_Then_Save_As_Xls(sWsh As String, sFilenameSrc As String, sFilenameTrg As String) '#
Dim Wbk As Workbook
Rem Workbook - Add
Set Wbk = Workbooks.Add
With Wbk
With .Worksheets(1)
Rem QueryTable - Add
With .QueryTables.Add(Connection:="TEXT;" & sFilenameSrc, Destination:=.Cells(1))
Rem QueryTable - Properties
.SaveData = True
.TextFileParseType = xlDelimited
.TextFileDecimalSeparator = "."
.TextFileThousandsSeparator = ","
.TextFileConsecutiveDelimiter = False
.TextFileTabDelimiter = True
.TextFileTrailingMinusNumbers = True
.TextFilePlatform = 65001 'Unicode (UTF-8)
.Refresh BackgroundQuery:=False
Rem QueryTable - Delete
.Delete
End With
Rem Rename Worksheet '#
On Error Resume Next '# Ignore error in case the Filename is not valid as Sheetname
.Name = sWsh '#
On Error GoTo 0 '#
End With
Rem Workbook - Save & Close
.SaveAs Filename:=sFilenameTrg, FileFormat:=xlOpenXMLWorkbook
.Close
End With
End Sub
With a delimited file that has a csv extension, Excel's Open and vba Workbooks.Open and Workbooks.OpenText methods will always assume that the delimiter is a comma, no matter what you put into the argument.
You can change the file extension (eg to .txt), and then the .Open method should work.
You could read it into a TextStream object and parse it line by line in VBA
You can Import the file rather than Opening the file.
You could use Power Query to import it.
Or you could use a variation of the code below, which was just generated by the macro recorder, so you'll have to clean it up and adapt it a bit to your specifics.
With ActiveSheet.QueryTables.Add(Connection:= _
"TEXT;D:\Users\Ron\Desktop\myFile.csv", Destination:=Range("$A$12"))
.CommandType = 0
.Name = "weather_1"
.FieldNames = True
.RowNumbers = False
.FillAdjacentFormulas = False
.PreserveFormatting = True
.RefreshOnFileOpen = False
.RefreshStyle = xlInsertDeleteCells
.SavePassword = False
.SaveData = True
.AdjustColumnWidth = True
.RefreshPeriod = 0
.TextFilePromptOnRefresh = False
.TextFilePlatform = 437
.TextFileStartRow = 1
.TextFileParseType = xlDelimited
.TextFileTextQualifier = xlTextQualifierDoubleQuote
.TextFileConsecutiveDelimiter = False
.TextFileTabDelimiter = True
.TextFileSemicolonDelimiter = False
.TextFileCommaDelimiter = False
.TextFileSpaceDelimiter = False
.TextFileColumnDataTypes = Array(1, 1, 1, 1)
.TextFileTrailingMinusNumbers = True
.Refresh BackgroundQuery:=False
End With
This method uses File System Object and Text Stream to change from tab delimited to comma delimited. Select Microsoft Scripting Runtime inside of Tools/References to make available the library used. If semicolon delimited also does not open correctly, you can replace third parameter of REPLACE function in line fileContents = Replace(fileContents, vbTab, ";") with comma and try again. Note we are creating a .csv file with Set textStreamObj = fileSystemObj.CreateTextFile("filePath2.csv"), not overwriting our original.
Option Explicit
Sub changeDelimitedMarker()
Dim fileSystemObj As Scripting.FileSystemObject
Dim textStreamObj As Scripting.TextStream
Dim fileContents As String
Set fileSystemObj = New FileSystemObject
Set textStreamObj = fileSystemObj.OpenTextFile("filePath1.csv")
fileContents = textStreamObj.ReadAll
textStreamObj.Close
fileContents = Replace(fileContents, vbTab, ",")
Set textStreamObj = fileSystemObj.CreateTextFile("filePath2.csv")
textStreamObj.Write fileContents
textStreamObj.Close
End Sub
Using the ADODB.Stream object, you can create a user-defined function.
Sub all()
Dim sourcepath As String
Dim sDir As String
Dim newpath As String
Dim vResult As Variant
Dim Wb As Workbook
Dim Fn As String
sourcepath = "C:\Users\PC\Desktop\Test\"
newpath = sourcepath & "xlsx\"
'make sure subfolder xlsx was created before
sDir = Dir$(sourcepath & "*.csv", vbNormal)
Application.ScreenUpdating = False
Do Until Len(sDir) = 0
'Workbooks.Open (sourcepath & sDir)
'use adodb.stream
vResult = TransToTextWithCsvUTF_8(sourcepath & sDir)
Fn = Replace(sDir, ".csv", ".xlsx")
Set Wb = Workbooks.Add
With Wb
Range("a1").Resize(UBound(vResult, 1) + 1, UBound(vResult, 2) + 1) = vResult
.SaveAs Filename:=newpath & Fn, FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False
.Close
End With
sDir = Dir$
Loop
Application.ScreenUpdating = True
End Sub
Function TransToTextWithCsvUTF_8(strFn As String) As Variant
Dim vR() As String
Dim i As Long, r As Long, j As Integer, c As Integer
Dim objStream As Object
Dim strRead As String
Dim vSplit, vRow
Dim s As String
Set objStream = CreateObject("ADODB.Stream")
With objStream
.Charset = "utf-8"
.Open
.LoadFromFile strFn
strRead = .ReadText
.Close
End With
vSplit = Split(strRead, vbCrLf)
r = UBound(vSplit)
c = UBound(Split(vSplit(0), vbTab, , vbTextCompare))
ReDim vR(0 To r, 0 To c)
For i = 0 To r
vRow = Split(vSplit(i), vbTab, , vbTextCompare)
If UBound(vRow) = c Then 'if it is empty line, skip it
For j = 0 To c
If IsNumeric(vRow(j)) Then
s = Format(vRow(j), "#,##0.000")
s = Replace(s, ".", "+")
s = Replace(s, ",", ".")
s = Replace(s, "+", ",")
vR(i, j) = s
Else
vR(i, j) = vRow(j)
End If
Next j
End If
Next i
TransToTextWithCsvUTF_8 = vR
Set objStream = Nothing
End Function
The Text to Columns should work for this:
Sub all()
Dim sourcepath As String
Dim sDir As String
Dim newpath As String
sourcepath = "C:\Users\snapier\Downloads\Test\"
newpath = sourcepath & "xlsx\"
'make sure subfolder xlsx was created before
sDir = Dir$(sourcepath & "*.csv", vbNormal)
Do Until Len(sDir) = 0
Workbooks.Open (sourcepath & sDir)
With ActiveWorkbook.Worksheets(1)
.UsedRange.TextToColumns Destination:=Range("A1"), DataType:=xlDelimited, _
TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=True, Tab:=True, _
Semicolon:=False, Comma:=False, Space:=False, Other:=False
End With
With ActiveWorkbook
.SaveAs Filename:=Replace(Left(.FullName, InStrRev(.FullName, ".")), sourcepath, newpath) & "xlsx", FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False
.Close
End With
sDir = Dir$
Loop
End Sub
I have a large file that downloads prices on a daily basis and then saves a backup copy of the file under a new name with a date suffix attached. Want to save this only on the local drive and not have it automatically upload to Sharepoint. This is for two reasons (1) speed -- at times the network connection is slow and saving to Sharepoint degrades performance and (2) the "Uploading to Sharepoint" dialog seems to hang, even after the file has clearly been uploaded.
Even though I've turn autosave off, it seems to automatically come back on when the .SaveAs code runs. Is this because of the file format that has been chosen? I'm generally using .xlsb to reduce file size.
Here is the code that I'm using:
Dim OrigName As String
Dim FilePath As String
Dim NewName As String
Dim DateSuffix As String
If ActiveWorkbook.AutoSaveOn = True Then
ActiveWorkbook.AutoSaveOn = False
Application.AutoRecover.Enabled = False
End If
SaveStart = Timer
Sheets("Parameters").Activate
RptDt = Range("End_Date").Offset(0, 1)
DateSuffix = Format(RptDt, "yyyymmdd") 'Year(RptDt) & Month(RptDt) & Day(RptDt)
Path = ActiveWorkbook.Path
OrigName = ActiveWorkbook.Name
OrigName = Left(ActiveWorkbook.Name, (InStrRev(ActiveWorkbook.Name, ".", -1, vbTextCompare) - 1))
NewName = OrigName & " " & DateSuffix
If Right(ActiveWorkbook.Name, 4) = "xlsb" Then
NewName = Path & "\" & NewName & ".xlsb"
OrigName = Path & "\" & OrigName & ".xlsb"
Else
NewName = Path & "\" & NewName & ".xlsm"
OrigName = Path & "\" & OrigName & ".xlsm"
End If
Application.Calculation = xlCalculationManual
With ActiveWorkbook
If Right(.Name, 4) = "xlsb" Then
Application.DisplayAlerts = False
.SaveAs NewName, FileFormat:=xlExcel12
Application.DisplayAlerts = True
BeforeSave2 = Timer
Application.DisplayAlerts = False
.SaveAs OrigName, FileFormat:=xlExcel12
Application.DisplayAlerts = True
Else
Application.DisplayAlerts = False
.SaveAs NewName, FileFormat:=52
Application.DisplayAlerts = True
Application.DisplayAlerts = False
.SaveAs OrigName, FileFormat:=52
Application.DisplayAlerts = True
End If
End With
Application.DisplayAlerts = True
ActiveWorkbook.AutoSaveOn = True
Application.AutoRecover.Enabled = True
Here's the revised code using SaveCopyAs:
NewName = NewName & ".xlsb"
OrigName = OrigName & ".xlsb"
With ActiveWorkbook
If Right(.Name, 4) = "xlsb" Then
Application.DisplayAlerts = False
.SaveCopyAs NewName
.SaveCopyAs OrigName
Application.DisplayAlerts = True
Else
Application.DisplayAlerts = False
.SaveCopyAs NewName
.SaveCopyAs OrigName
Application.DisplayAlerts = True
End If
End With
I have a workbook that contains a macro that i wish to use to update the location of a connection in another workbook. The VBA script creates a folder, populates it with a log file containing data called log.txt and a copy of an excel file that is pre formatted to fill with the data allowing the user to see graphs and a detailed breakdown of the data. it is a door opening log, tracking numbers of times the door has been used.
here is the VBA code I've come up with so far.
note: I did a couple of years programming in C++ but haven't touched it in a decade. I have tried searching around for the code and even recording a macro of the actions I take when refreshing the connection manually. however if I try and use that code it gives a "Run time error 1004" Application defined or object defined error.
Here is the code. The commented out bit at the bottom is the result of the macro recorded from manually altering the connection.
Any help would be greatly received.
Sub Lof_File_Macro()
' Log_file_Macro Macro
' Runs script for monthly counts '
Dim strfolder1, strmonthno, strmonth, stryear, strfoldername, strfile, strmonyr, stlogfile, strfutfile
'date strings defined using date functions - ofset for 28 days to allow running anytime within 20 days into the next month whilereturning correct month
strmonthno = Month(Date - 28)
strmonth = MonthName((strmonthno), True)
stryear = Year(Date - 28)
strmonyr = " " & strmonth & " " & stryear
strfolder = "C:\Users\jtaylor7\Desktop\futures\People Counter" & strmonyr
strfile = "Futures People" & strmonyr & ".xls"
strlogfile = strfolder & "\" & "log" & strmonyr & ".txt"
strfutfile = strfolder & "\" & strfile
MkDir (strfolder)
FileCopy "C:\Users\jtaylor7\Desktop\futures\log.log", strlogfile
FileCopy "C:\Users\jtaylor7\Desktop\futures\template.xls", strfutfile
'Workbooks.Open Filename:=strfutfile
'ActiveWorkbook.Connections.AddFromFile (strlogfile)
'
'
' Perform data connection modification on file
'' Windows(strfutfile).Activate
' With ActiveWorkbook.Connections("log")
' .Name = "log"
' .Description = ""
' End With
' Range("$A$1:$H$1").Select
'With Selection.QueryTable
' .Connection = "TEXT;strlogfile"
' .TextFilePlatform = 850
' .TextFileStartRow = 1
' .TextFileParseType = xlDelimited
' .TextFileTextQualifier = xlTextQualifierDoubleQuote
' .TextFileConsecutiveDelimiter = False
' .TextFileTabDelimiter = False
' .TextFileSemicolonDelimiter = False
' .TextFileCommaDelimiter = True
' .TextFileSpaceDelimiter = False
' .TextFileOtherDelimiter = "/"
' .TextFileColumnDataTypes = Array(1, 1, 1, 1, 1, 1, 1, 1)
' .TextFileTrailingMinusNumbers = True
' .Refresh BackgroundQuery:=False
' End With
' Range("I4").Select
' ActiveWorkbook.Connections("log").Refresh
'' Windows("Run Me.xls").Activate
'
End Sub
I know its a bit messy, and if anyone needs any further data please ask.
Something like this should do the trick.
Pls update your paths from my testing below
Sub LogFile_Macro()
Dim strFolder As String
Dim strMonthno As String
Dim strMonth As String
Dim strYear As String
Dim strFoldername As String
Dim strFile As String
Dim strMonyr As String
Dim strLogfile As String
Dim strFutfile As String
Dim wb As Workbook
'date strings defined using date functions - ofset for 28 days to allow running anytime within 20 days into the next month whilereturning correct month
strMonthno = Month(Date - 28)
strMonth = MonthName((strMonthno), True)
strYear = Year(Date - 28)
strMonyr = " " & strMonth & " " & strYear
strFolder = "C:\temp\People Counter" & strMonyr
strFile = "Futures People" & strMonyr & ".xls"
strLogfile = strFolder & "\" & "log" & strMonyr & ".txt"
strFutfile = strFolder & "\" & strFile
On Error Resume Next
MkDir strFolder
If Err.Number <> 0 Then
MsgBox "cannot create path", vbCritical
Exit Sub
End If
On Error GoTo 0
FileCopy "C:\temp\futures\log.log", strLogfile
FileCopy "C:\temp\futures\template.xls", strFutfile
Set wb = Workbooks.Open(strFutfile)
With wb.Sheets(1).QueryTables.Add(Connection:="TEXT;" & strLogfile, Destination:=Range("A1:H1"))
.Name = "log"
.TextFilePlatform = 850
.TextFileStartRow = 1
.TextFileParseType = xlDelimited
.TextFileTextQualifier = xlTextQualifierDoubleQuote
.TextFileCommaDelimiter = True
.TextFileOtherDelimiter = "/"
.TextFileColumnDataTypes = Array(1, 1, 1, 1, 1, 1, 1, 1)
.TextFileTrailingMinusNumbers = True
.Refresh BackgroundQuery:=False
.Refresh
End With
Windows("Run Me.xls").Activate
End Sub
I'm using the following code to import all CSV files from D:\Report into Excel with each file on a new Sheet with the name of the file as the sheet name.
I'm looking to include some error control to allow the code to be run a second time if a file was not in the Report directory. The current problem is that the code will run again but bombs out as you cannot have the same name for two sheets and I dont want the same files imported again.
Sub ImportAllReportData()
'
' Import All Report Data
' All files in D:\Report will be imported and added to seperate sheets using the file names in UPPERCASE
'
Dim strPath As String
Dim strFile As String
'
strPath = "D:\New\"
strFile = Dir(strPath & "*.csv")
Do While strFile <> ""
With ActiveWorkbook.Worksheets.Add
With .QueryTables.Add(Connection:="TEXT;" & strPath & strFile, _
Destination:=.Range("A1"))
.Parent.Name = Replace(UCase(strFile), ".CSV", "")
.TextFileParseType = xlDelimited
.TextFileTextQualifier = xlTextQualifierDoubleQuote
.TextFileConsecutiveDelimiter = False
.TextFileTabDelimiter = False
.TextFileSemicolonDelimiter = False
.TextFileCommaDelimiter = True
.TextFileSpaceDelimiter = False
.TextFileColumnDataTypes = Array(1)
.TextFileTrailingMinusNumbers = True
.Refresh BackgroundQuery:=False
End With
End With
strFile = Dir
Loop
End Sub
Any help would be greatly appreciated
Use the following function to test if a WS already exists:
Function SheetExists(strShtName As String) As Boolean
Dim ws As Worksheet
SheetExists = False 'initialise
On Error Resume Next
Set ws = Sheets(strShtName)
If Not ws Is Nothing Then SheetExists = True
Set ws = Nothing 'release memory
On Error GoTo 0
End Function
Use it in your code like this:
....
strPath = "D:\New\"
strFile = Dir(strPath & "*.csv")
Do While strFile <> ""
If Not SheetExists(Replace(UCase(strFile), ".CSV", "")) Then
With ActiveWorkbook.Worksheets.Add
With .QueryTables.Add(Connection:="TEXT;" & strPath & strFile, _
.....
End If