Importing multiple text files using VBA Macro - excel

I have a daily dump of 2 different text files (in the same folder) that get overwritten daily. I would like to be able to import them into an active spreadsheet with tab delimited, at the same time with a VBA code. I would really appreciate the help!
I am using excel 2016. My manual import method of 1 of the text file when recorded gives this code which is how i would like BOTH the text files to be imported (formatting preserved):
With ActiveSheet.QueryTables.Add(Connection:= _
"TEXT;C:\Users\Mr D\Music\New folder\B.txt", Destination:=Range("$A$1"))
.CommandType = 0
.Name = "B"
.FieldNames = True
.RowNumbers =enter code here False
.FillAdjacentFormulas = False
.PreserveFormatting = True
.RefreshOnFileOpen = False
.RefreshStyle = xlInsertDeleteCells
.SavePassword = False
.SaveData = True
.AdjustColumnWidth = True
.RefreshPeriod = 0
.TextFilePromptOnRefresh = False
.TextFilePlatform = 1252
.TextFileStartRow = 1
.TextFileParseType = xlDelimited
.TextFileTextQualifier = xlTextQualifierDoubleQuote
.TextFileConsecutiveDelimiter = False
.TextFileTabDelimiter = True
.TextFileSemicolonDelimiter = False
.TextFileCommaDelimiter = False
.TextFileSpaceDelimiter = False
.TextFileColumnDataTypes = Array(1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, _
1)
.TextFileTrailingMinusNumbers = True
.Refresh BackgroundQuery:=False
End With
End Sub
The code that i have tried using is from other similar questions posted here does not seem to work:
Sub ReadFilesIntoActiveSheet()
Dim fso As FileSystemObject
Dim folder As folder
Dim file As file
Dim FileText As TextStream
Dim TextLine As String
Dim Items() As String
Dim i As Long
Dim cl As Range
' Get a FileSystem object
Set fso = New FileSystemObject
' get the directory you want
Set folder = fso.GetFolder("C:\Users\Mr D\Music\")
' set the starting point to write the data to
Set cl = ActiveSheet.Cells(1, 1)
' Loop thru all files in the folder
For Each file In folder.Files
' Open the file
Set FileText = file.OpenAsTextStream(ForReading)
' Read the file one line at a time
Do While Not FileText.AtEndOfStream
TextLine = FileText.ReadLine
' Parse the line into | delimited pieces
Items = Split(TextLine, "|")
' Put data on one row in active sheet
For i = 0 To UBound(Items)
cl.Offset(0, i).Value = Items(i)
Next
' Move to next row
Set cl = cl.Offset(1, 0)
Loop
' Clean up
FileText.Close
Next file
Set FileText = Nothing
Set file = Nothing
Set folder = Nothing
Set fso = Nothing
End Sub

do like this if your text files is with tab delimited.
Sub ReadFilesIntoActiveSheet()
Dim fso As FileSystemObject
Dim folder As folder
Dim file As file
Dim FileText As TextStream
Dim TextLine As String
Dim Items() As String
Dim i As Long
Dim cl As Range
Dim sFolder As String, vDB, Ws As Worksheet
Dim rngT As Range
' Get a FileSystem object
Set fso = New FileSystemObject
' get the directory you want
sFolder = "C:\Users\Mr D\Music\"
Set folder = fso.GetFolder(sFolder)
' set the starting point to write the data to
Set Ws = ActiveSheet
'Set cl = ActiveSheet.Cells(1, 1)
' Loop thru all files in the folder
For Each file In folder.Files
Workbooks.Open Filename:=sFolder & file.Name, Format:=1
With ActiveWorkbook.ActiveSheet
vDB = .UsedRange
End With
ActiveWorkbook.Close
Set rngT = Ws.Range("a" & Rows.Count).End(xlUp)(2)
rngT.Resize(UBound(vDB, 1), UBound(vDB, 2)) = vDB
Next file
Ws.Range("a1").EntireRow.Delete
Set FileText = Nothing
Set file = Nothing
Set folder = Nothing
Set fso = Nothing
End Sub
From the second text file, the header will be ignored.
Sub ReadFilesIntoActiveSheet()
Dim fso As FileSystemObject
Dim folder As folder
Dim file As file
Dim FileText As TextStream
Dim TextLine As String
Dim Items() As String
Dim i As Long
Dim cl As Range
Dim sFolder As String, vDB, Ws As Worksheet
Dim rngT As Range
' Get a FileSystem object
Set fso = New FileSystemObject
' get the directory you want
sFolder = "C:\Users\Mr D\Music\"
Set folder = fso.GetFolder(sFolder)
' set the starting point to write the data to
Set Ws = ActiveSheet
'Set cl = ActiveSheet.Cells(1, 1)
Ws.Cells.Clear
' Loop thru all files in the folder
For Each file In folder.Files
i = i + 1
Workbooks.Open Filename:=sFolder & file.Name, Format:=1
With ActiveWorkbook.ActiveSheet
If i = 1 Then
vDB = .UsedRange
Else
vDB = .UsedRange.Offset(1)
End If
End With
ActiveWorkbook.Close
Set rngT = Ws.Range("a" & Rows.Count).End(xlUp)(2)
rngT.Resize(UBound(vDB, 1), UBound(vDB, 2)) = vDB
Next file
Ws.Range("a1").EntireRow.Delete
Set FileText = Nothing
Set file = Nothing
Set folder = Nothing
Set fso = Nothing
End Sub

Related

Excel VBA HTML Import Formatting

I have been using the below vba from another thread and have modified it to allow html vs txt.
When it imports the HTML it works fine but the html is spread out over multiple rows and not contained to one cell.
Is there a way to restrict the html to once cell only?
I need all the html to be in one cell as I need to process about 500 html files regularly and i just require it to be in individual cells.
Any help appreciated.
Sub ImportTXTFiles()
Dim FSO As Object
Dim xlsheet As Worksheet
Dim qt As QueryTable
Dim txtfilesToOpen As Variant, txtfile As Variant
Application.ScreenUpdating = False
Set FSO = CreateObject("Scripting.FileSystemObject")
txtfilesToOpen = Application.GetOpenFilename _
(FileFilter:="Text Files (*.html), *.html", _
MultiSelect:=True, Title:="HTML Files to Open")
With ActiveSheet
For Each txtfile In txtfilesToOpen
importrow = 1 + .Cells(.Rows.Count, 1).End(xlUp).Row
' IMPORT DATA FROM TEXT FILE
With .QueryTables.Add(Connection:="TEXT;" & txtfile, _
Destination:=.Cells(importrow, 1))
.TextFileParseType = xlDelimited
.TextFileConsecutiveDelimiter = False
.TextFileTabDelimiter = False
.TextFileSemicolonDelimiter = False
.TextFileCommaDelimiter = False
.TextFileSpaceDelimiter = False
.TextFileOtherDelimiter = "$"
.Refresh BackgroundQuery:=False
End With
Next txtfile
For Each qt In .QueryTables
qt.Delete
Next qt
End With
Application.ScreenUpdating = True
MsgBox "Successfully imported text files!", vbInformation, "SUCCESSFUL IMPORT"
Set FSO = Nothing
End Sub
Try the next code, please:
Sub ImportTXTFiles()
Dim FSO As Object, txtStr As Object, strText As String, sh As Worksheet
Dim txtfilesToOpen As Variant, txtfile As Variant, importrow As Long
Set FSO = CreateObject("Scripting.FileSystemObject")
Set sh = ActiveSheet ' use here your sheet
txtfilesToOpen = Application.GetOpenFilename _
(FileFilter:="Text Files (*.html), *.html", _
MultiSelect:=True, Title:="HTML Files to Open")
For Each txtfile In txtfilesToOpen
importrow = 1 + sh.cells(Rows.count, 1).End(xlUp).Row
Set txtStr = FSO.OpenTextFile(txtfile)
strText = txtStr.ReadAll
txtStr.Close
If Len(strText) <= 32000 Then
sh.cells(importrow, 1).Value = strText:
Else
MsgBox txtfile & " size exceeds the limit of 32000 digits..."
End If
Next txtfile
MsgBox "Successfully imported text files!", vbInformation, "SUCCESSFUL IMPORT"
Set FSO = Nothing
End Sub
It checks the limit of a cell string size (32k characters) and rise a message for such a case... If necessary, it can split the string in portions of 32k and paste in the next cells, marking in B:B 1, 2 ... x portion numbers...

Excel Vba dictionary not looped

I have this code that is supposed to iterate through my folder and add the file names into the dictionary, however after adding my extraction code inside this for loop, only data from the last file in the folder will be extracted because everytime it collects data from the next file, it will overwrite the row and column "A2:M2" and not continue adding on.
UPDATED
Public Dict As Object
Sub EEE()
Application.ScreenUpdating = False
Application.EnableEvents = False
Application.Calculation = xlCalculationManual
Application.DisplayStatusBar = False
Dim oFSO As Object, oFolder As Object, ofile As Object
Set oFSO = CreateObject("Scripting.fileSystemObject")
Set oFolder = oFSO.GetFolder("C:\Users\Desktop\file\")
If Dict Is Nothing Then
Set Dict = CreateObject("Scripting.Dictionary")
Dict.Add Key:="filename", Item:=ofile
End If
For Each ofile In oFolder.Files
If Not Dict.Exists(oFSO.GetBaseName(ofile)) Then
Dim basePath As Variant
basePath = "C:\Users\Desktop\file\"
Dim baseFolder As Scripting.Folder
With New Scripting.FileSystemObject
Set baseFolder = .GetFolder(basePath)
End With
Dim file As Scripting.file
For Each file In baseFolder.Files
Dim a As Range
Dim wkbData As Workbook
Set wkbData = Workbooks.Open(file.path)
Dim wksData As Worksheet
ActiveSheet.Name = "Book1"
Set wksData = wkbData.Worksheets("Book1") ' -> Assume this file has only 1 worksheet
Dim LastRow As Long
LastRow = wks.Range("A" & wks.Rows.count).End(xlUp).row + 1
wks.Cells(LastRow, 6).value = file.Name
Set a = wksData.Columns("A:A").Find(" test1234 : ", LookIn:=xlValues)
If Not a Is Nothing Then
wks.Cells(LastRow, 1) = Split(a.value, ":")(1)
End If
wkbData.Close False
Range("A:M").EntireColumn.AutoFit
Range("A1").AutoFilter
Debug.Print "A: " & oFSO.GetBaseName(ofile)
Dict.Add oFSO.GetBaseName(ofile), 1
Next file
Else
'skip
Debug.Print "E: " & oFSO.GetBaseName(ofile)
End If
Next ofile
Application.ScreenUpdating = True
Application.EnableEvents = True
Application.DisplayStatusBar = True
End Sub

Find String and extract in vba using fso

so my code currently goes through a folder and extracts Ranges of data from every file in the folder into a format set by me, it also extracts the filename.
Now i need to use fso to search for certain string inside the file not the filename, lets say "Smart", and in the file "Smart" appears quite a few times, but i only want to extract it once.
Thank you so much to anyone who is able to provide me the small part of the code or some advices to help me continue on!
Option Explicit
Sub ScanFiles()
Application.ScreenUpdating = False
Dim wks As Worksheet
Set wks = Worksheets.Add
' New worksheet for question 2
Dim wksFSO As Worksheet
' Add headers data
With wks
.Range("A1:E1") = Array("Test", "Temp", "Start", "Type", "FileName", "Test", "EndDate", "Smart", "Er")
End With
' Set your copy ranges
Dim CopyRange(1 To 4) As String
CopyRange(1) = "A18"
CopyRange(2) = "A19"
CopyRange(3) = "A14"
CopyRange(4) = "A19"
' Early Binding - Add "Microsoft Scripting Runtime" Reference
Dim FSO As New Scripting.FileSystemObject
' Set FolderPath
Dim FolderPath As String
FolderPath = "c:\Users\Desktop\Tryout\"
' Set Folder FSO
Dim Folder As Scripting.Folder
Set Folder = FSO.GetFolder(FolderPath)
' Loop thru each file -> Assuming only 6 files
Dim File As Scripting.File
For Each File In Folder.Files
' If loop looking for specific files and copy to new FSOWorksheet
If File.Name Like "ReportFile" Then
wksFSO.Cells(1, 1) = File.Name
End If
Dim wkbData As Workbook
Set wkbData = Workbooks.Open(File.Path)
Dim wksData As Worksheet
ActiveSheet.Name = "Sheet1"
Set wksData = wkbData.Worksheets("Sheet1") ' -> Assume this file has only 1 worksheet
Dim BlankRow As Long
BlankRow = wks.Range("A" & wks.Rows.Count).End(xlUp).Row + 1
Dim i As Long
For i = 1 To 4
wks.Cells(BlankRow, i).Value = wksData.Range(CopyRange(i)).Value
Next i
' Write filename in col E
wks.Cells(BlankRow, 5).Value = File.Name
wkbData.Close False
Next File
Range("A:I").EntireColumn.AutoFit
Application.ScreenUpdating = True
End Sub
This could help you, what it does is it search through the path's folders and each excel file that is inside it for the word that you are going to put in the input box.
Sub SearchFolders()
Dim fso As Object
Dim fld As Object
Dim strSearch As String
Dim strPath As String
Dim strFile As String
Dim wOut As Worksheet
Dim wbk As Workbook
Dim wks As Worksheet
Dim lRow As Long
Dim rFound As Range
Dim strFirstAddress As String
On Error GoTo ErrHandler
Application.ScreenUpdating = False
'Change as desired
strPath = "c:\MyFolder"
'You can enter your smart word here
strSearch = inputbox("Please enter a word to be searched.","Search for a word")
Set wOut = Worksheets.Add
lRow = 1
With wOut
.Cells(lRow, 1) = "Workbook"
.Cells(lRow, 2) = "Worksheet"
.Cells(lRow, 3) = "Cell"
.Cells(lRow, 4) = "Text in Cell"
Set fso = CreateObject("Scripting.FileSystemObject")
Set fld = fso.GetFolder(strPath)
strFile = Dir(strPath & "\*.xls*")
Do While strFile <> ""
Set wbk = Workbooks.Open _
(Filename:=strPath & "\" & strFile, _
UpdateLinks:=0, _
ReadOnly:=True, _
AddToMRU:=False)
For Each wks In wbk.Worksheets
Set rFound = wks.UsedRange.Find(strSearch)
If Not rFound Is Nothing Then
strFirstAddress = rFound.Address
End If
Do
If rFound Is Nothing Then
Exit Do
Else
lRow = lRow + 1
.Cells(lRow, 1) = wbk.Name
.Cells(lRow, 2) = wks.Name
.Cells(lRow, 3) = rFound.Address
.Cells(lRow, 4) = rFound.Value
End If
Set rFound = wks.Cells.FindNext(After:=rFound)
Loop While strFirstAddress <> rFound.Address
Next
wbk.Close (False)
strFile = Dir
Loop
.Columns("A:D").EntireColumn.AutoFit
End With
MsgBox "Done"
ExitHandler:
Set wOut = Nothing
Set wks = Nothing
Set wbk = Nothing
Set fld = Nothing
Set fso = Nothing
Application.ScreenUpdating = True
Exit Sub
ErrHandler:
MsgBox Err.Description, vbExclamation
Resume ExitHandler
End Sub

Automatic Import (daily, csv & xls --> xls(m))

C
Dear SO-Community
i've got the following problem/challenge:
I need to automatically and daily import some data into one "master-xls". Both the source data and the consolidated data is organised in the same structure (plz have a look at the examples below)
Is it possibe, either way - with VBA (preferable) or without VBA - to automatically import data from the source files (file name is a combination of a string and the actual date) into the "destination-file"
Help and tips are very much appreciated! Plz point me into the right direction instead of presenting an already working example.
It is important, that the data from the new source file is appended to the data which is already existing!
best wishes,
Luke
source files:
*source 1
*source 2
master file
*master xls
I'm going to point you in the right direction, assuming I understand you correctly.
If you're opening up and wanting to read from an Excel spreadsheet, this will be useful:
Dim cnn As ADODB.Connection
Dim rst As ADODB.Recordset
Dim cmd As ADODB.Command
'Set up the Connection to Excel
Set cnn = New ADODB.Connection
With cnn
.Provider = "Microsoft.ACE.OLEDB.12.0" 'or whatever your provider is
.ConnectionString = "Data Source="C:\My_source_file.xlsx';Extended Properties='Excel 12.0 Xml;HDR=NO;IMEX=1';"
.Open
End With
'Set up the command to get all that mess out the spreadsheet.
Set cmd = New ADODB.Command
With cmd
.ActiveConnection = cnn
.CommandText = "SELECT * FROM [WhateverSheetHasMyData$]"
End With
'Load up the recordset with everything in the worksheet.
Set rst = New ADODB.Recordset
With rst
.CursorLocation = adUseClient
.CursorType = adOpenDynamic
.LockType = adLockOptimistic
.Open cmd
End With
This should get you going in the direction you'd like to go. I am sure you can extrapolate from this how you might also use a command to deposit the data you've loaded into some other document, such as another spreadsheet or a database table.
Also, when it comes to appending the information, Excel has a nifty thing:
...
Dim ws As Excel.Worksheet
Dim lastrow As Integer
Set ws = wb.Sheets(1) 'wb being your workbook object; you could also use the sheet name instead of the index here
ws.Activate
lastrow = ws.Cells.SpecialCells(11).Row 'gets you the last row
So, you can use that lastrow+1 value as the starting point for your insert.
As an aside,
"Help and tips are very much appreciated! Plz do not bother to point me into the right direction..."
^ Generally not a good thing to say around these parts. Especially when you just said "I appreciate your help, but please don't bother helping me."
Have fun with this.
i've finally managed to automate the csv import.
some parts of the solution are originally found here:
http://software-solutions-online.com/2014/03/05/list-files-and-folders-in-a-directory/
below is my solution:
Sub listfiles_dir()
Dim objFSO As Object
Dim objFolder As Object
Dim objFile As Object
Dim i As Integer
Dim lastrow As Integer
Dim lastcolumn As Integer
Dim wb As Excel.Workbook
Dim ws As Excel.Worksheet
Dim header As Boolean
header = True
Set wb = ActiveWorkbook
Set ws = wb.Sheets("raw")
ws.Activate
ws.Cells.ClearContents
Application.DisplayAlerts = False
Application.ScreenUpdating = False
'Create an instance of the FileSystemObject
Set objFSO = CreateObject("Scripting.FileSystemObject")
'Get the folder object
'Set objFolder = objFSO.GetFolder(".\data")
Set objFolder = objFSO.GetFolder(ThisWorkbook.Path & "\data")
i = 1
'loops through each file in the directory and prints their names and path
For Each objFile In objFolder.Files
'print file name
'Cells(i + 1, 1) = objFile.Name
'print file path
'Cells(i + 1, 2) = objFile.Path
i = i + 1
Debug.Print (objFile.Path)
If header = True Then
lastrow = 5
Else
lastrow = ws.Range("A" & Rows.Count).End(xlUp).row + 1 'gets you the last row
End If
Call import_csv(ws, objFile.Path, header, lastrow)
lastcolumn = ws.Range("$A$" & CStr(lastrow)).End(xlToRight).Column + 1
Cells(lastrow, lastcolumn) = objFile.Name
Debug.Print (lastcolumn)
If header = True Then
header = False
End If
Next objFile
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub
'import files
Sub import_csv(sheet As Worksheet, fname As String, header As Boolean, row As Integer)
'
' importCSV Macro
'
Dim startingrow As Integer
startingrow = 1
If header = False Then
startingrow = 2
End If
Debug.Print ("$A$" & CStr(row))
With sheet.QueryTables.Add(Connection:= _
"TEXT;" & fname, Destination:=Range( _
"$A$" & CStr(row)))
.FieldNames = True
.RowNumbers = False
.FillAdjacentFormulas = False
'.PreserveFormatting = True
.RefreshOnFileOpen = False
.RefreshStyle = xlInsertDeleteCells
.SavePassword = False
'.SaveData = True
.AdjustColumnWidth = True
.RefreshPeriod = 0
.TextFilePromptOnRefresh = False
.TextFileStartRow = startingrow
.TextFileParseType = xlDelimited
.TextFileTextQualifier = xlTextQualifierDoubleQuote
.TextFileConsecutiveDelimiter = False
.TextFileTabDelimiter = False
.TextFileSemicolonDelimiter = True
.TextFileCommaDelimiter = False
.TextFileSpaceDelimiter = False
.TextFileTrailingMinusNumbers = True
.Refresh BackgroundQuery:=False
End With
End Sub

using delimiter as column format for impoted txt files

how can I apply delimiter "^" as columns from imported multiple txt files. Pls Help. ..
Private Sub CommandButton1_Click()
Application.ScreenUpdating = False
Dim oFileDialog As FileDialog
Dim LoopFolderPath As String
Dim oFileSystem As FileSystemObject
Dim oLoopFolder As Folder
Dim oFilePath As File
Dim oFile As TextStream
Dim RowN As Long
Dim ColN As Long
Dim iAnswer As Integer
On Error GoTo ERROR_HANDLER
Set oFileDialog = Application.FileDialog(msoFileDialogFolderPicker)
RowN = 1
ColN = 1
With oFileDialog
If .Show Then
ActiveSheet.Columns(ColN).Cells.Clear
LoopFolderPath = .SelectedItems(1) & "\"
Set oFileSystem = CreateObject("Scripting.FileSystemObject")
Set oLoopFolder = oFileSystem.GetFolder(LoopFolderPath)
For Each oFilePath In oLoopFolder.Files
Set oFile = oFileSystem.OpenTextFile(oFilePath)
With oFile
Do Until .AtEndOfStream
ActiveSheet.Cells(RowN, ColN).Value = .ReadLine
LoopFolderPath = Space(1)
RowN = RowN + 1
Loop
.Close
End With
Next oFilePath
End If
iAnswer = MsgBox("Your Textfiles have been Inputted.", vbInformation)
End With
EXIT_SUB:
Set oFilePath = Nothing
Set oLoopFolder = Nothing
Set oFileSystem = Nothing
Set oFileDialog = Nothing
Application.ScreenUpdating = True
Exit Sub
ERROR_HANDLER:
' Some code for error handling
Err.Clear
GoTo EXIT_SUB
End Sub
ActiveSheet.RangE("X:X").TextToColumns Destination:=Range("X#"), DataType:=xlDelimited, _
TextQualifier:=xlDoubleQuote, Other:=True, OtherChar:="^"
Of course you will need to replace X:X by the proper column and X# by the proper range.
It took about 30 seconds using the macro recorder to get that code.

Resources