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.
Related
The below code copies data from multiple worksheets and consolidates into database (database worksheet). I am trying to add a new column at the last unused column of database worksheet that gives the name of the sheets in each row, the data is copied from with the column header as "Sheet Name". The problem is, I am trying to start with adding the header by using wsData.Range(1, wsData.Cells(1, Columns.Count).End(xlToLeft).Offset(0, 1)).Value = "SheetName", but unfortunately, it is giving an error.
The program is currently taking 6 minutes to process around 25,000 rows, so is there a way to make it faster?
I am not very well-versed with VBA and I received the below code from another stack overflow question. Below is my code. Any help will be appreciated.
Sub ProcessWorkbooks()
Application.ScreenUpdating = False
Application.EnableEvents = False
Application.DisplayAlerts = False
Dim f, wsData As Worksheet, wbSrc As Workbook, map As Object
Set wsData = ThisWorkbook.Sheets("Database")
wsData.UsedRange.ClearContents 'clear any existing data
Dim fldr1 As FileDialog
Dim iFile As String
Set fldr1 = Application.FileDialog(msoFileDialogFolderPicker)
With fldr1
.Title = "Select InputFile Folder... "
.ButtonName = "Select"
.AllowMultiSelect = False
.InitialFileName = Application.DefaultFilePath
If .Show = -1 Then
iFile = .SelectedItems(1)
Else
Exit Sub
End If
End With
Dim strPath As String
strPath = iFile
Dim oFSO As Object
Dim oFolder As Object
Dim oFile As Object
Set oFSO = CreateObject("Scripting.FileSystemObject")
Set oFolder = oFSO.GetFolder(strPath)
Dim abc As Boolean
abc = False
For Each oFile In oFolder.Files
If oFile.Name Like "*xls*" Then
Set wbSrc = Workbooks.Open(oFolder & "\" & oFile.Name)
ImportData wbSrc, wsData, abc
wbSrc.Close False
End If
Next oFile
With wsData.Range("A1").CurrentRegion
.Font.Size = 9
.Font.Name = "Calibri"
.Borders.LineStyle = xlLineStyleNone
.EntireColumn.AutoFit
End With
Application.ScreenUpdating = True
MsgBox Title:="Task Box", Prompt:="Database Created!"
End Sub
Sub ImportData(wbIn As Workbook, wsData As Worksheet, abc as Boolean)
Dim lrData As Long, lrSrc As Long, ws As Worksheet, c As Range
Dim Process, hdr, m, n
Process = Array("Manila", "Cebu", "Davao", "CDO", "Bacolod")
Application.ScreenUpdating = False
For Each ws In wbIn.Worksheets
Call KillFilter
n = ws.Name
lrData = wsData.Cells(Rows.Count, "A").End(xlUp).Row + 1
'lrData = SheetLastRow(wsData) + 1
If lrData = 1 Then lrData = 2 'in case no headers yet...
lrSrc = SheetLastRow(ws)
For Each c In ws.Range("A1", ws.Cells(1, Columns.Count).End(xlToLeft)).Cells
hdr = c.Value
m = Application.Match(hdr, wsData.Rows(1), 0) 'existing column match?
If IsError(m) Then
m = Application.CountA(wsData.Rows(1))
m = IIf(m = 0, 1, m + 1)
wsData.Cells(1, m).Value = hdr 'add as new column header
End If
ws.Range(c.Offset(1), ws.Cells(lrSrc, c.Column)).Copy _
wsData.Cells(lrData, m)
Next c
If abc = False Then
wsData.Range(1, wsData.Cells(1, Columns.Count).End(xlToLeft).Offset(0, 1)).Value = "SheetName"
abc = True
End If
Next ws
End Sub
'return the last used row in a worksheet
Function SheetLastRow(ws As Worksheet) As Long
Dim f As Range
Set f = ws.Cells.Find("*", ws.Range("A1"), xlFormulas, xlPart, xlByRows, xlPrevious)
If Not f Is Nothing Then SheetLastRow = f.Row 'otherwise 0
End Function
See below for how to add the sheet name, and some other suggestions:
Option Explicit
Sub ProcessWorkbooks()
Dim f, wsData As Worksheet, wbSrc As Workbook, map As Object, strPath As String
Dim oFSO As Object, oFile As Object, nextRow As Long
On Error GoTo haveError 'ensures event/calc settings are restored
Application.ScreenUpdating = False
Application.EnableEvents = False
Application.Calculation = xlCalculationManual
strPath = ChooseFolder("Select InputFile Folder... ") 'made this a new Function
If Len(strPath) = 0 Then Exit Sub
Set wsData = ThisWorkbook.Sheets("Database")
With wsData
.UsedRange.ClearContents 'clear any existing data
.Range("A1").value = "Sheet Name" 'add the sheet name header
End With
Set oFSO = CreateObject("Scripting.FileSystemObject")
For Each oFile In oFSO.getfolder(strPath).Files
If oFile.name Like "*.xls*" Then
Set wbSrc = Workbooks.Open(oFile.Path)
ImportData wbSrc, wsData
wbSrc.Close False
End If
Next oFile
With wsData.Range("A1").CurrentRegion
.Font.Size = 9
.Font.name = "Calibri"
.Borders.LineStyle = xlLineStyleNone
.EntireColumn.AutoFit
End With
haveError:
Application.ScreenUpdating = True
Application.EnableEvents = True
Application.Calculation = xlCalculationAutomatic
MsgBox Title:="Task Box", Prompt:="Database Created!"
End Sub
'assumes there's always a "sheet Name" header in A1 of wsData
Sub ImportData(wbIn As Workbook, wsData As Worksheet)
Dim lrData As Long, lrSrc As Long, ws As Worksheet, c As Range
Dim Process, hdr, m
Process = Array("Manila", "Cebu", "Davao", "CDO", "Bacolod") '????
For Each ws In wbIn.Worksheets
If ws.FilterMode Then ws.ShowAllData 'remove any filtering
lrData = wsData.Cells(Rows.Count, "A").End(xlUp).Row + 1 'paste row
lrSrc = SheetLastRow(ws)
wsData.Cells(lrData, "A").Resize(lrSrc - 1).value = ws.name '<<< add the sheet name....
For Each c In ws.Range("A1", ws.Cells(1, ws.Columns.Count).End(xlToLeft)).Cells
hdr = c.value
m = Application.Match(hdr, wsData.Rows(1), 0) 'existing column match?
If IsError(m) Then 'need to add this header?
m = wsData.Cells(1, Columns.Count).End(xlToLeft).Column + 1
wsData.Cells(1, m).value = hdr
End If
ws.Range(c.Offset(1), ws.Cells(lrSrc, c.Column)).Copy _
wsData.Cells(lrData, m)
Next c
Next ws
End Sub
'Ask user to select a folder. Returns empty string if none selected
Function ChooseFolder(prmpt As String) As String
Dim fldr1 As FileDialog, fldr As String
Dim iFile As String
Set fldr1 = Application.FileDialog(msoFileDialogFolderPicker)
With fldr1
.Title = prmpt
.ButtonName = "Select"
.AllowMultiSelect = False
.InitialFileName = Application.DefaultFilePath
If .Show = -1 Then ChooseFolder = .SelectedItems(1)
End With
End Function
'return the last used row in a worksheet
Function SheetLastRow(ws As Worksheet) As Long
Dim f As Range
Set f = ws.Cells.Find("*", ws.Range("A1"), xlFormulas, xlPart, xlByRows, xlPrevious)
If Not f Is Nothing Then SheetLastRow = f.Row 'otherwise 0
End Function
I am running the following code. The code is for finding some particular values in all the Excel sheets in a folder.
It gives me the error
"Sorry, we couldn't find the file. Is it possible it was moved, renamed or deleted?"
when it executes
Set wbSlave = Workbooks.Open(filename:=myfilname)
Please help.
Sub find_cells()
Dim i, j As Integer
Dim cell_content As String
Dim total_values As Long
Dim cell_location As Range
Dim cell_address As String
Dim sht As Worksheet
Dim myfilname As String
Dim fldrpath As String
Dim wbMaster As Workbook
Dim wbSlave As Workbook
Dim currentfilename As String
Set wbMaster = ThisWorkbook
j = 3
total_values = Application.WorksheetFunction.CountA(wbMaster.Sheets("Engine").Range("A:A"))
fldrpath = "C:\test\"
myfilname = Dir(fldrpath & "*.xls*")
Application.ScreenUpdating = False
Do While myfilname <> ""
'myfilname = Dir()
Set wbSlave = Workbooks.Open(filename:=myfilname)
For Each sht In wbSlave.Sheets
For i = 2 To total_values
cell_content = wbMaster.Sheets("Engine").Range("A" & i).Value
With sht.UsedRange
Set cell_location = .Find(cell_content, LookIn:=xlValues, MatchCase:=False, SearchFormat:=False)
If Not cell_location Is Nothing Then
cell_address = cell_location.Address
Do
wbMaster.Sheets("Sheet1").Columns(j).Value = cell_location.EntireColumn.Value
j = j + 1
Set cell_location = .FindNext(cell_location)
Loop While Not cell_location Is Nothing And cell_location.Address <> cell_address
End If
End With
Set cell_location = Nothing
If i = total_values Then Exit For
Next i
Next
myfilname = Dir()
Loop
End Sub
The Dir function returns only the matching filename - no path. Then if you try to open it and you are currently not in a correct folder, you get this error.
Set a watch to the variable myfilname or just add Debug.Print myfilname and you see it right away.
https://learn.microsoft.com/en-us/office/vba/language/reference/user-interface-help/dir-function
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
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
I have about 100 Word documents and from each I want to copy data and paste it all in one Excel workbook.
I came up with this code which opens one Word document, copies data, pastes it to Excel and closes the Word document:
Sub WordDataToExcel()
Dim myObj
Dim myWB
Dim mySh
Dim txt As String, Lgth As Long, Strt As Long
Dim i As Long
Dim oRng As Range
Dim Tgt As String
Dim TgtFile As String
Dim arr()
Dim ArrSize As Long
Dim ArrIncrement As Long
ArrIncrement = 1000
ArrSize = ArrIncrement
ReDim arr(ArrSize)
Dim wrdDoc As Object
Documents.Open ("D:\ekr5_i.doc")
TgtFile = "result.xlsx"
Tgt = "D:\" & TgtFile
'finds the text string of Lgth lenght
txt = "thetext"
Lgth = 85
Strt = Len(txt)
'Return data to array
With Selection
.HomeKey unit:=wdStory
With .Find
.ClearFormatting
.Forward = True
.Text = txt
.Execute
While .Found
i = i + 1
Set oRng = ActiveDocument.Range _
(Start:=Selection.Range.Start + Strt, _
End:=Selection.Range.End + Lgth)
arr(i) = oRng.Text
oRng.Start = oRng.End
.Execute
If i = ArrSize - 20 Then
ArrSize = ArrSize + ArrIncrement
ReDim Preserve arr(ArrSize)
End If
Wend
End With
End With
ReDim Preserve arr(i)
'Set target and write data
Set myObj = CreateObject("Excel.Application")
Set myWB = myObj.Workbooks.Open(Tgt)
Set mySh = myWB.Sheets(1)
With mySh
.Range(.Cells(1, 1), .Cells(i, 1)) = myObj.Transpose(arr)
End With
'Tidy up
myWB.Close True
myObj.Quit
ActiveDocument.Close SaveChanges:=wdDoNotSaveChanges
Set mySh = Nothing
Set myWB = Nothing
Set myObj = Nothing
End Sub
I need to loop through all the documents in the folder.
I have implemented the same with Excel workbooks, but I don't know how for Word documents.
Here is the code for Excel workbooks:
Sub combine_into_one()
Dim FSO As Object: Set FSO = CreateObject("Scripting.FileSystemObject")
Dim strPath$, Pivot$, sUserName$, sFolderName$, sSourceName$, x&
Dim oFldialog As FileDialog
Dim oFolder
Application.DisplayAlerts = False
Application.ScreenUpdating = False
Set oFldialog = Application.FileDialog(msoFileDialogFolderPicker)
With oFldialog
If .Show = -1 Then
.Title = "Select a Folder"
.AllowMultiSelect = False
.InitialFileName = strPath
sFolderName = .SelectedItems(1)
End If
End With
Set oFolder = FSO.GetFolder(sFolderName)
Workbooks.Add: Pivot = ActiveWorkbook.Name 'Destination workbook
For Each oFile In oFolder.Files
Workbooks(Pivot).Activate
x = Workbooks(Pivot).Sheets(1).Cells.SpecialCells(xlCellTypeLastCell).Row + 1
Workbooks.Open Filename:=oFile: sSourceName = ActiveWorkbook.Name
Workbooks(sSourceName).Activate
Workbooks(sSourceName).Sheets(1).[A80:Q94].copy
Workbooks(Pivot).Activate
Workbooks(Pivot).Sheets(1).Cells(x + 1, 1).PasteSpecial xlPasteAll
Workbooks(sSourceName).Close False
Next
Application.CutCopyMode = False
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub
There are so, so, so many things you can do between Excel & Word. I'm not sure I totally understand your question. The script below may help you; it has definitely served me well over time. If you need something different, please describe your issue more, to better clarify the issue you are facing.
Sub OpenAndReadWordDoc()
Rows("2:1000000").Select
Range(Selection, Selection.End(xlDown)).Select
Selection.ClearContents
Range("A1").Select
' assumes that the previous procedure has been executed
Dim oWordApp As Word.Application
Dim oWordDoc As Word.Document
Dim blnStart As Boolean
Dim r As Long
Dim sFolder As String
Dim strFilePattern As String
Dim strFileName As String
Dim sFileName As String
Dim ws As Worksheet
Dim c As Long
Dim n As Long
'~~> Establish an Word application object
On Error Resume Next
Set oWordApp = GetObject(, "Word.Application")
If Err Then
Set oWordApp = CreateObject("Word.Application")
' We started Word for this macro
blnStart = True
End If
On Error GoTo ErrHandler
Set ws = ActiveSheet
r = 1 ' startrow for the copied text from the Word document
' Last column
n = ws.Range("A1").End(xlToRight).Column
sFolder = "C:\Users\Excel\Desktop\Coding\Microsoft Excel\PWC\Resumes\"
'~~> This is the extension you want to go in for
strFilePattern = "*.doc*"
'~~> Loop through the folder to get the word files
strFileName = Dir(sFolder & strFilePattern)
Do Until strFileName = ""
sFileName = sFolder & strFileName
'~~> Open the word doc
Set oWordDoc = oWordApp.Documents.Open(sFileName)
' Increase row number
r = r + 1
' Enter file name in column A
ws.Cells(r, 1).Value = sFileName
ActiveCell.Offset(1, 0).Select
ActiveSheet.Hyperlinks.Add Anchor:=Sheets("Sheet1").Range("A" & r), Address:=sFileName, _
SubAddress:="A" & r, TextToDisplay:=sFileName
' Loop through the columns
For c = 2 To n
If oWordDoc.Content.Find.Execute(FindText:=Trim(ws.Cells(1, c).Value), _
MatchWholeWord:=True, MatchCase:=False) Then
' If text found, enter Yes in column number c
ws.Cells(r, c).Value = "Yes"
End If
Next c
oWordDoc.Close SaveChanges:=False
'~~> Find next file
strFileName = Dir
Loop
ExitHandler:
On Error Resume Next
' close the Word application
Set oWordDoc = Nothing
If blnStart Then
' We started Word, so we close it
oWordApp.Quit
End If
Set oWordApp = Nothing
Exit Sub
ErrHandler:
MsgBox Err.Description, vbExclamation
Resume ExitHandler
End Sub
Function GetDirectory(path)
GetDirectory = Left(path, InStrRev(path, "\"))
End Function
In this scenario, whatever you put in the headers of B1:K1 (or more to the right) is searched for, each word document in a folder is opened, scanned, and if the string in B1:K1 is found, an 'x' is placed in the same x-y coordinate.
Again, if this doesn't help, please describe your issue better, and I'll post back with alternative solutions. Thanks!!