UPDATED CODE AND ISSUES (5/9/2018 1:53PM Eastern)
I am encountering problems trying to import multiple data text files into a fixed worksheet ("Raw Data") using two different delimiters. I am using Application.GetOpenFilename to allow the user to select multiple text files from a folder. The files contain a header row which is semicolon delimited, then several lines of data which is comma delimited. In a single text file, this format can be repeated several times (this is an inspection log file which records and appends data to the same text file for each inspection run, i.e. header line1, some rows of data, header line 2, more rows of data, header line 3, more rows of data, etc.)
I've tried a few approaches to solve this based on other examples I've found on StackOverflow.com but I can't seem to successfully mesh the solutions together to come up with a solution that imports single or multiple text files with two different delimiters within each file. I cannot change the format or content of the original text files, so I can't search and replace different delimiters to a single delimiter.
Here are the remaining issues I'm running into with the attached VBA code:
When importing more than one text file, a blank line is inserted between the files which breaks the .TextToColumns section. It is also asking to replace existing data when importing the second file selected. Is there a more efficient or better way to import data from multiple text files using both commas and semicolons as delimiters?
Within a fixed path on the local hard drive, each new order number creates a new sub-folder to store .txt data files (i.e. C:\AOI_DATA64\SPC_DataLog\IspnDetails\123456-7). Is there a way the user can be prompted to enter a sub-folder name (123456-7) and the VBA script will automatically import all .txt files from this sub-folder, rather than using Application.GetOpenFilename?
Here is a truncated version of one of the data files I'm trying to import. The actual file does not have spaces between the rows of data. I separated them in this example to clearly show each line in the text file.
[StartIspn];Time=04/19/18 12:43:15;User=yeseniar;MachineID=WINDOWS-TEFJCS1;Side=T;DoubleSided;IsOnline=1;IA_Idx=1;SN_Idx=0;IT=0;SPC_Db=1;SPC_Txt=1;TxtFmt=10;E_Rpt=1;D_Img=1;FeedMode=0;
KC17390053F,VIA5F,M North,A8,85.0,45.0,96.0,23.2,9.9,0.0,0.0,0.0,59.0,0.0,0.0,0.0,
KC17390053F,VIA3F,M North,A8,85.0,45.0,96.0,22.3,22.9,0.0,0.0,0.0,59.0,0.0,0.0,0.0,
KC17390053F,FMI1F,S South,A13,12.3,0.0,1.0,3.5,3.5,0.0,0.0,0.0,0.0,0.0,0.0,0.0,
KC17390053F,FMI13F,S South,A13,12.3,0.0,1.0,3.5,3.5,0.0,0.0,0.0,0.0,0.0,0.0,0.0,
[StartIspn];Time=04/19/18 14:28:10;User=yeseniar;MachineID=WINDOWS-TEFJCS1;Side=B;DoubleSided;IsOnline=1;IA_Idx=1;SN_Idx=0;IT=0;SPC_Db=1;SPC_Txt=1;TxtFmt=10;E_Rpt=1;D_Img=1;FeedMode=0;
KC17390066B,VIA5B,M North,A8,70.0,50.0,92.0,-38.8,-3.7,0.0,0.0,0.0,50.0,0.0,0.0,0.0,
KC17390066B,VIA6B,M North,A8,70.0,50.0,93.0,-37.7,-23.6,0.0,0.0,0.0,50.0,0.0,0.0,0.0,
KC17390066B,FMI12B,S South,A13,4140.4,0.0,2.0,3.5,129.6,0.0,0.0,0.0,0.0,0.0,0.0,0.0,
KC17390066B,FMI24B,S South,A13,2128.7,0.0,2.0,3.5,119.1,0.0,0.0,0.0,0.0,0.0,0.0,0.0,
Here is what I have so far for importing multiple text files:
Sub Import_DataFile()
' Add an error handler
On Error GoTo ErrorHandler
' Speed up this sub-routine by turning off screen updating and auto calculating until the end of the sub-routine
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
' Define variable names and types
Dim OpenFileName As Variant
Dim i As Long
Dim n1 As Long
Dim n2 As Long
Dim fn As Integer
Dim RawData As String
Dim rngTarget As Range
Dim rngFileList As Range
Dim TargetRow As Long
Dim FileListRow As Long
Dim dLastRow As Long
Dim destCell As Range
' Select the source folder and point list file(s) to import into worksheet
OpenFileName = Application.GetOpenFilename( _
FileFilter:="AOI Inspection Results Data Files (*.txt), *.txt", _
Title:="Select a data file or files to import", _
MultiSelect:=True)
' Import user selected file(s) to "Raw Data" worksheet
TargetRow = 0
Set destCell = Worksheets("Raw Data").Range("B1")
For n2 = LBound(OpenFileName) To UBound(OpenFileName)
fn = FreeFile
Open OpenFileName(n2) For Input As #fn
Application.StatusBar = "Processing ... " & OpenFileName(n2)
Do While Not EOF(fn)
Line Input #fn, RawData
TargetRow = TargetRow + 1
Worksheets("Raw Data").Range("B" & TargetRow).Formula = RawData
Loop
Next n2
Close #fn
Set rngTarget = Worksheets("Raw Data").Range("B1" & ":" & Worksheets("Raw Data").Range("B1").End(xlDown).Address)
With rngTarget
.TextToColumns Destination:=destCell, DataType:=xlDelimited, _
TextQualifier:=xlNone, ConsecutiveDelimiter:=False, Tab:=False, _
Semicolon:=True, Comma:=True, Space:=False, Other:=False, OtherChar:="|", _
FieldInfo:=Array(1, 1), TrailingMinusNumbers:=True
End With
Else: MsgBox "The selected file is not the correct format for importing data."
Exit Sub
End If
Next
' Create a number list (autofill) in Col A to maintain original import sort order
dLastRow = Worksheets("Raw Data").Cells(Rows.Count, "B").End(xlUp).Row
Worksheets("Raw Data").Range("A1:A" & dLastRow).Font.Color = RGB(200, 200, 200)
Worksheets("Raw Data").Range("A1") = "1"
Worksheets("Raw Data").Range("A2") = "2"
Worksheets("Raw Data").Range("A1:A2").AutoFill Destination:=Worksheets("Raw Data").Range("A1:A" & dLastRow), Type:=xlFillDefault
Worksheets("Raw Data").Range("F1:Q" & dLastRow).NumberFormat = "0.0"
' Auto fit the width of columns for RAW Data
Worksheets("Raw Data").Columns("A:Z").EntireColumn.AutoFit
' Turn screen updating and auto calculating back on since file processing is now complete
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
' Reset to defaults in the event of a processing error during the sub-routine execution
ErrorHandler:
Application.StatusBar = False
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
If Err.Number <> 0 Then
' Display a message to the user including the error code in the event of an error during execution
MsgBox "An error number " & Err.Number & " was encountered!" & vbNewLine & _
"Part or all of this VBA script was not completed.", vbInformation, "Error Message"
End If
End Sub
Many questions... Let me give some hints.
Prompting the user for working directory :
Dim fDlg As FileDialog ' dialog box object
Dim sDir As String ' selected path
Dim iretval As Long ' test
Set fDlg = Application.FileDialog(msoFileDialogFolderPicker)
sDir = conDEFAULTPATH ' init
With fDlg
.Title = "Select a Folder"
.AllowMultiSelect = False
.InitialFileName = sDir
iretval = .Show
If iretval = -1 Then sDir = .SelectedItems(1)
End With
Set fDlg = Nothing ' drop object
If sDir = vbNullString Then
MsgBox "Invalid directory"
Else
If Right$(Trim$(sDir), 1) <> Application.PathSeparator Then _
sDir = Trim$(sDir) & Application.PathSeparator' append closing backslash to pathname
End If
Collecting files to a buffer
Dim FileBuf(100) as string, FileCnt as long
FileCnt=0
FileBuf(FileCnt)=Dir(sDir & "*.txt")
Do While FileBuf(FileCnt) <> vbnullstring
FileCnt = FileCnt + 1
FileBUf(FileCnt) = Dir
Loop
Reducing number of delimiters: simply use replace
RawData = Replace(RawData, ";", ",")
For the blank line I have no clue, though it might be a result of a blank line in the source file, maybe the EOF. So what if you check the line before copying:
If len(trim(RawData)) > 0 Then
TargetRow = TargetRow + 1
Worksheets("Raw Data").Range("B" & TargetRow) = RawData
End If
Please note that I've removed .Formula. You are working with values.
For setting target range: You should omit .Address. For selecting last cell in a range, you should use .End(xlUp) this way:
Set rngTarget = Worksheets("Raw Data").Range("B1" & ":" & Worksheets("Raw Data").Range("B1").End(xlUp))
I prefer using direct cell references, so - as you exactly know the last row - I would do it this way:
Set rngTarget = Worksheets("Raw Data").Range(Cells(1, 2), Cells(TargetRow, 2))
Good Luck!
I'm just new in using excel vba macro. I am trying to create text file and use the cell values as name of individual text file. At the first place the value contains character and those character will be replaced. the only value will remain are all numbers. That function is working well. My problem is once I execute the create button, the program will create an extra text file which name is base on empty cell and no any input "D" as input in the text file. What I want is to create a text file without that extra text file created. below is my excel format and the code.
I have 3 column use as below:
LOG DATA INPUT BLOCK NAME
5687 D ASD
5689 D
5690 D
5692 D
5691 D
5688 D
4635 D
Correct result will create four text file:
abc-5687.req
abc-5689.req
abc-5690.req
abc-5692.req
Result with extra text file consider as wrong see below:
abc-.req <-- extra text file created
abc-5687.req
abc-5689.req
abc-5690.req
abc-5692.req
my code:
Private Sub CREATE_REQ_Click()
Dim myDataSheet As Worksheet
Dim myReplaceSheet As Worksheet
Dim myLastRow As Long
Dim myRow As Long
Dim myFind As String
Dim myReplace1 As String
Dim myReplace2 As String
Dim sExportFolder, sFN
Dim rArticleName As Range
Dim rDisclaimer As Range
Dim oSh As Worksheet
Dim oFS As Object
Dim oTxt As Object
' Specify name of Data sheet
Set myDataSheet = Sheets("Sheet1")
' Specify name of Sheet with list of replacements
Set myReplaceSheet = Sheets("Sheet2")
' Assuming list of replacement start in column A on row 2, find last entry in list
myLastRow = myReplaceSheet.Cells(Rows.Count, "A").End(xlUp).Row
Application.ScreenUpdating = False
' Loop through all list of replacments
For myRow = 2 To myLastRow
' Get find and replace values (from columns A and B)
myFind = myReplaceSheet.Cells(myRow, "A")
myReplace1 = myReplaceSheet.Cells(myRow, "B")
' Start at top of data sheet and do replacements
myDataSheet.Activate
Range("A2").Select
' Ignore errors that result from finding no matches
On Error Resume Next
' Do all replacements on column A of data sheet
Columns("A:A").Replace What:=myFind, Replacement:=myReplace1, LookAt:=xlPart, SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, ReplaceFormat:=False
Next myRow
sExportFolder = "D:\TEST\REQ_FILES_CREATED_HERE"
Set oSh = Sheet1
Set oFS = CreateObject("Scripting.Filesystemobject")
For Each rArticleName In oSh.UsedRange.Columns("A").Cells
Set rDisclaimer = rArticleName.Offset(, 1)
If rArticleName = "" & "LOG DATA" Then
oTxt = False
Else
'Add .txt to the article name as a file name
sFN = "-" & rArticleName.Value & ".req"
Set oTxt = oFS.OpenTextFile(sExportFolder & "\" & ActiveSheet.Cells(2, 3) & sFN, 2, True)
oTxt.Write rDisclaimer.Value
oTxt.Close
End If
Next
'Reset error checking
On Error GoTo 0
Application.ScreenUpdating = True
MsgBox "Replacements complete! "
End Sub
For Each rArticleName In oSh.UsedRange.Columns("A").Cells
Set rDisclaimer = rArticleName.Offset(, 1)
If Not(rArticleName = "" Or rArticleName = "LOG DATA") Then
'Add .txt to the article name as a file name
sFN = "-" & rArticleName.Value & ".req"
Set oTxt = oFS.OpenTextFile(sExportFolder & "\" & ActiveSheet.Cells(2, 3) & sFN, 2, True)
oTxt.Write rDisclaimer.Value
oTxt.Close
End If
Next
Pretty close to a one line fix. You just need to fix the If. Once that's right you don't need the Else.
I am extremely green when it comes to VBA. However I need a VBA script inside an existing workbook that will create a csv from a specific range of cells on a separate worksheet in the workbook. I have a button that I created on sheet 1 that when clicked grabs the data on sheet 3. I also need the data formatted in the same manor in which it is displayed on the sheet3. The range of cells on sheet 3 is A1:E12. The biggest issue I am having is with the formatting. I have attached an example of the format of the data on sheet 3:ExcelSheet3Data
Sub InfoBlox()
Host = Sheet1.Range("C4").Value
Dim rCell As Range
Dim rRow As Range
Dim vaColPad As Variant
Dim i As Long
Dim sOutput As String
Dim sFname As String, lFnum As Long
Const sDELIM As String = ";"
'Required width of columns
vaColPad = Array(0, 0, 6, 0, 4)
i = LBound(vaColPad)
'Open a text file to write
sFname = "c:\fcbnoc" & "\" & Host & "-INFOBLOX-CONFIG" & ".csv"
lFnum = FreeFile
Open sFname For Output As lFnum
'Loop through the rows
For Each rRow In Sheet3.UsedRange.Rows
'Loop through the cells in the rows
For Each rCell In rRow.Cells
'If the cell value is less than required, then pad
'it with zeros, else just use the cell value
'If Len(rCell.Value) < vaColPad(i) Then
'sOutput = sOutput & Application.Rept(0, _
'vaColPad(i) & Len(rCell.Value)) & rCell.Value & sDELIM
'Else
sOutput = sOutput & rCell.Value
'& sDELIM (this value generates an extra delimiter at the end of every line).
'End If
'i = i + 1
Next rCell
'remove the last comma
sOutput = Left(sOutput, Len(sOutput))
'write to the file and reinitialize the variables
Print #lFnum, sOutput
sOutput = ""
i = LBound(vaColPad)
Next rRow
'Close the file
Close lFnum
End Sub
I am sure I am making this more difficult than I need, but appreciate any help that is provided.
I would like to loop through an Excel worksheet and to store the values based on a unique ID in a text file.
I am having trouble with the loop and I have done research on it with no luck and my current nested loop continually overflows. Instead of updating the corresponding cell when the control variable is modified, it continues to store the initial Index value for all 32767 iterations.
Please can someone explain why this is happening, and provide a way of correcting it?.
Sub SortLetr_Code()
'sort columns for Letr_Code files
Dim lr As Long
Application.ScreenUpdating = False
lr = Cells(Rows.Count, 1).End(xlUp).Row
Range("A2:B" & lr).Sort key1:=Range("B2"), order1:=1
Application.ScreenUpdating = True
'Value of cell for example B1 starts out as X
Dim x As Integer
Dim y As Integer
x = 2
y = 2
'Cell References
Dim rwCounter As Range
Dim rwCorresponding As Range
Dim rwIndexValue As Range
Dim rwIndexEnd As Range
Dim rwIndexStore As Range
'Variables for files that will be created
Dim FilePath As String
Dim Filename As String
Dim Filetype As String
'Variables defined
FilePath = "C:\Users\Home\Desktop\SURLOAD\"
Filetype = ".dat"
'Use Cell method for Loop
rwIndex = Cells(x, "B").Value
Set rwCounter = Range("B" & x)
'Use Range method for string manipulation
Set rwCorresponding = Range("A" & x)
Set rwIndexValue = Range("B" & y)
Set rwIndexStore = Range("B" & x)
Set rwIndexEnd = Range("B:B").End(xlUp)
'Objects for creating the text files
Dim FileCreate As Object
Set FileCreate = CreateObject("Scripting.FileSystemObject")
'Object for updating the file during the loop
Dim FileWrite As Object
For Each rwIndexStore In rwIndexEnd.Cells
'Get Substring of cell value in BX for the file name
Do Until IsEmpty(rwCounter)
Filename = Mid$(rwIndexValue, 7, 5)
Set FileWrite = FileCreate.CreateTextFile(FilePath + Filename + Filetype)
'Create the file
FileWrite.Write (rwCorresponding & vbCrLf)
Do
'Add values to the textfile
x = x + 1
FileWrite.Write (rwCorresponding & vbCrLf)
Loop While rwCounter.Value Like rwIndexValue.Value
'Close this file
FileWrite.Close
y = x
Loop
Next rwIndexStore
End Sub
I don't see a place you are setting rwCounter inside the loop.
It looks like it would stay on range("B2") and x would just continue to increase until it hits an error, either at the limit of integer or long.
add Set rwCounter = Range("B" & x) somewhere inside your loop to increment it
This is the solution.
Sub GURMAIL_File()
'sort columns for Letr_Code files
Dim lr As Long
Application.ScreenUpdating = False
lr = Cells(Rows.Count, 1).End(xlUp).Row
Range("A2:B" & lr).Sort key1:=Range("B2"), order1:=1
Application.ScreenUpdating = True
'Variables that store cell number
Dim Corresponding As Integer
Dim Index As Integer
Dim Counter As Integer
Corresponding = 2
Index = 2
Counter = 2
'Cell References
Dim rwIndexValue As Range
'Variables for files that will be created
Dim l_objFso As Object
Dim FilePath As String
Dim Total As String
Dim Filename As String
Dim Filetype As String
Dim FolderName As String
'Variables defined
FilePath = "C:\Users\Home\Desktop\SURLOAD\"
'Name of the folder to be created
FolderName = Mid$(ActiveWorkbook.Name, 9, 8) & "\"
'Folder path
Total = FilePath & FolderName
'File Extension
Filetype = ".dat"
'Object that creates the folder
Set l_objFso = CreateObject("Scripting.FileSystemObject")
'Objects for creating the text files
Dim FileCreate As Object
Set FileCreate = CreateObject("Scripting.FileSystemObject")
'Object for updating the file during the loop
Dim FileWrite As Object
'Get Substring of letter code in order to name the file. End this loop once ID field is null.
Do While Len(Range("A" & Corresponding)) > 0
'Create the directory if it does not exist
If Not l_objFso.FolderExists(Total) Then
l_objFso.CreateFolder (Total)
End If
'Refence to cell containing a letter code
Set rwIndexValue = Range("B" & Index)
'Substring of that letter code
Filename = Mid$(rwIndexValue, 7, 5)
'Create the file using the substring and store it in the proper location
Set FileWrite = FileCreate.CreateTextFile(Total + Filename + Filetype, True)
'For each letter code, find the corresponding values. End the loop once the last value for the letter code is stored.
Do While Range("B" & Index) Like Range("B" & Counter)
'Add each line to the text file.
FileWrite.WriteLine (Range("A" & Corresponding))
'Incrementer variables that allow you to exit the loop
'if you have reached the last value of the current letter code.
Corresponding = Corresponding + 1
Counter = Counter + 1
Loop
'Close the file you were writing to
FileWrite.Close
'Make sure that Index value is updated to the next letter code
Index = Counter
'In case Index value needs updating (safeguard to make sure that the new letter code is stored to index value).
Set rwIndexValue = Range("B" & Index)
Loop
End Sub
I want to show 7000 files content that are in a folder and in excel?
I have a found a piece of code that helped me but its only reading one by one. However, I want to read 7000 all in one go. Please help.
Option Explicit
Sub Import_TXT_File()
Dim strg As Variant
Dim EntireLine As String
Dim FName As String
Dim i As String
Application.ScreenUpdating = False
FName = Application.GetOpenFilename("Text Files (*.txt), *.txt", , "Choose File to Import")
Open FName For Input Access Read As #1
i = 1
While Not EOF(1)
Line Input #1, EntireLine
strg = EntireLine
'Change "Sheet1" to relevant Sheet Name
'Change "A" to the relevant Column Name
Sheets("Sheet1").Range("A" & i).Value = strg
i = i + 1
Wend
EndMacro:
On Error GoTo 0
Application.ScreenUpdating = True
Close #1
End Sub
user1185158
The code which you are using will be very slow when you are reading 7000 files. Also there is no code which can read 7000 files in 1 go. You will have to loop through the 7000 files. However there is one good news :) Instead of looping through every line in the text file, you can read the entire file into an array and then write it to excel. For example see this code which is very fast as compared to the code that you have above.
TRIED AND TESTED
Sub Sample()
Dim MyData As String, strData() As String
Open "C:\MyFile.Txt" For Binary As #1
MyData = Space$(LOF(1))
Get #1, , MyData
Close #1
strData() = Split(MyData, vbCrLf)
End Sub
Now using the same code in a loop we can write it into an Excel File
'~~> Change this to the relevant path
Const strPath As String = "C:\Temp\"
Sub Sample()
Dim ws As Worksheet
Dim MyData As String, strData() As String
Dim WriteToRow As Long, i As Long
Dim strCurrentTxtFile As String
Set ws = Sheets("Sheet1")
'~~> Start from Row 1
WriteToRow = 1
strCurrentTxtFile = Dir(strPath & "*.Txt")
'~~> Looping through all text files in a folder
Do While strCurrentTxtFile <> ""
'~~> Open the file in 1 go to read it into an array
Open strPath & strCurrentTxtFile For Binary As #1
MyData = Space$(LOF(1))
Get #1, , MyData
Close #1
strData() = Split(MyData, vbCrLf)
'~~> Read from the array and write to Excel
For i = LBound(strData) To UBound(strData)
ws.Range("A" & WriteToRow).Value = strData(i)
WriteToRow = WriteToRow + 1
Next i
strCurrentTxtFile = Dir
Loop
MsgBox "Done"
End Sub
What the above code does is that it reads the contents of the 7000 text files in sheet 1 (one below the other). Also I have not included error handling. Please do that.
CAUTION: If you are reading heavy text files, say, each file has 10000 lines then you will have to tweak the code in the above scenario as you will get errors. for example
7000 Files * 10000 lines = 70000000 lines
Excel 2003 has 65536 rows and Excel 2007/2010 has 1048576 rows.
So once the WriteRow reaches the maximum row, you might want to read the text file contents into Sheet 2 and so on...
HTH
Sid
Taking Siddharth's solution a little further. You probably don't want to write each row one at a time, calls to the worksheet are extremely slow in Excel, it is better to do any looping in memory and write back in one fell swoop :)
Sub Sample()
Dim ws As Worksheet
Dim MyData As String, strData() As String, strData2() As String
Dim WriteToRow As Long, i As Long
Dim strCurrentTxtFile As String
Set ws = Sheets("Sheet1")
'~~> Start from Row 1
WriteToRow = 1
strCurrentTxtFile = Dir(strPath & "*.Txt")
'~~> Looping through all text files in a folder
Do While strCurrentTxtFile <> ""
'~~> Open the file in 1 go to read it into an array
Open strPath & strCurrentTxtFile For Binary As #1
MyData = Space$(LOF(1))
Get #1, , MyData
Close #1
strData = Split(MyData, vbCrLf)
'Resize and transpose 1d array to 2d
ReDim strData2(1 To UBound(strData) + 1, 1 To 1)
For i = 1 To UBound(strData)
strData2(i, 1) = strData(i - 1)
Next i
Sheet1.Range("A1").Offset(Sheet1.Rows.Count - 1, 0).End(xlUp).Offset(1).Resize(UBound(strData), 1).Value = strData2
strCurrentTxtFile = Dir
Loop
MsgBox "Done"
End Sub