I've found a lot on importing folder of .txt files into excel, but not many on importing .txt files into word. I'm trying to get my macro to open all .txt files in a specific folder and import them into a single word document, with each .txt file having its own page. This is the code I have so far (that I found online):
Sub AllFilesInFolder()
Dim myFolder As String, myFile As String
myFolder = Application.FileDialog(msoFileDialogFolderPicker)
With Application.FileDialog(msoFileDialogFolderPicker)
.AllowMultiSelect = False
.Show
If .SelectedItems.Count > 0 Then
myFolder = .SelectedItems(1)
End If
End With
myFile = Dir(myFolder & "\*.txt") '
Do While myFile <> ""
Open myFolder & "\" & myFile For Input As #1
'Copy & Paste Macro?
myFile = Dir
Loop
End Sub
here is something to get you started
Word 2010
Edit this should allow you to open all txt files in one document and save it
Option Explicit
Sub AllFilesInFolder()
Dim myFolder As String
Dim myFile As String
Dim wdDoc As Document
Dim txtFiles As Document
Application.ScreenUpdating = False
myFolder = openFolder
If myFolder = "" Then Exit Sub
myFile = Dir(myFolder & "\*.txt", vbNormal)
Set wdDoc = ActiveDocument
While myFile <> ""
Set txtFiles = Documents.Open(FileName:=myFolder & "\" & myFile, AddToRecentFiles:=False, Visible:=False, ConfirmConversions:=False)
wdDoc.Range.InsertAfter txtFiles.Range.Text & vbCr
txtFiles.Close SaveChanges:=True
myFile = Dir()
Wend
Set txtFiles = Nothing
Set wdDoc = Nothing
Application.ScreenUpdating = True
End Sub
Function openFolder() As String
Dim oFolder As Object
openFolder = ""
Set oFolder = CreateObject("Shell.Application").BrowseForFolder(0, "Choose a folder", 0)
If (Not oFolder Is Nothing) Then openFolder = oFolder.Items.Item.Path
Set oFolder = Nothing
End Function
Copy all the text files into a single file using the Command Prompt (cmd.exe) and the following command:
copy *.txt NewFile.txt
Then open this file with word and modify the way you want to see the text.
Related
Set up a macro to open word documents through excel. It's been working fine, but after copying the code from the test environment into another file it's refusing to open word on every machine I test it on. Every other part of the macro is working fine, but for some reason word will no longer open via macro.
I've attached the code, but any help would be appreciated. It was working earlier today, and because of this i'm having trouble identifying the problem.
Public Function Method2(ByVal rngl As Range, ByVal strSearch As Variant, ByVal sPath As String)
Dim filePath As String
Dim directory As String
Dim fileName As String
Dim myPath As String
Dim myFile As File
Dim FSO As New FileSystemObject
Dim myFolder As Folder
Dim myExtension As String
Dim mySubFolder As Folder
Dim mySubFolder2 As Folder
Dim objWord
Dim objDoc
Dim rngRange
Dim rng1 As Range
Set myFolder = FSO.GetFolder(sPath)
directory = "S:\File Recipes\"
fileName = "Yaroze_Test"
myExtension = "*.docx*"
Set rng1 = Range("A:A").find(strSearch, , xlValues, xlWhole)
If strSearch = "" Then
MsgBox "Please Enter a Product Code!"
Exit Function
End If
If Not rng1 Is Nothing Then
MsgBox "Product Codes Found!"
For Each mySubFolder In myFolder.SubFolders
For Each mySubFolder2 In mySubFolder.SubFolders
For Each myFile In mySubFolder.Files
If InStr(myFile, strSearch) > 0 Then
fileName = Dir(myPath & myExtension)
MsgBox (myFile.Name)
Do While fileName <> ""
Set objWord = CreateObject("Word.Application")
objWord.Visible = True
ChDrive ("S")
ChDir ("S:\File Recipes\")
filePath = myFile.Path
MsgBox directory
objWord.Documents.Open fileName:=filePath
DoEvents
fileName = Dir
Loop
MsgBox "Task Complete!"
End If
Next
For Each myFile In mySubFolder2.Files
If InStr(myFile, strSearch) > 0 Then
fileName = Dir(myPath & myExtension)
' MsgBox (myFile.Name)
Do While fileName <> ""
Set objWord = CreateObject("Word.Application")
objWord.Visible = True
ChDrive ("S")
ChDir ("S:\File Recipes\")
filePath = myFile.Path
' MsgBox directory
objWord.Documents.Open fileName:=filePath
DoEvents
fileName = Dir
Loop
MsgBox "Task Complete!"
End If
Next
Next
Next
Else
MsgBox "Product Codes Not Found!"
End If
' Set rngRange = _
objWord.Range(objWord.Paragraphs(1).Start, objWord.Paragraphs(1).End - 1)
' rngRange.InsertAfter _
"This is now the last sentence in paragraph one."
I've attempted to test the Macro on other computers to see if it was just the copy of word I was using, and I've tested writing new Macros to open word. They worked initially but other macros are now no longer working. I've tried disabling office from references in VBA and testing with that, and I've made sure it's not an issue with instances of word being left open.
I have created a VBA code that loops through all excel workbooks in a given folder , opens then, refreshes the sheet, pauses for 10 seconds, closes and saves and moves on to the next. The issue I am facing is that it wont do it for the excel workbooks in the subfolder, Please can someone assist.
The code is as per below:
Sub LoopAllExcelFilesInFolder()
'PURPOSE: To loop through all Excel files in a user specified folder and perform a set task on them
'SOURCE: www.TheSpreadsheetGuru.com
Dim wb As Workbook
Dim myPath As String
Dim myFile As String
Dim myExtension As String
Dim FldrPicker As FileDialog
'Optimize Macro Speed
Application.ScreenUpdating = False
Application.EnableEvents = False
Application.Calculation = xlCalculationManual
'Retrieve Target Folder Path From User
Set FldrPicker = Application.FileDialog(msoFileDialogFolderPicker)
With FldrPicker
.Title = "Select A Target Folder"
.AllowMultiSelect = False
If .Show <> -1 Then GoTo NextCode
myPath = .SelectedItems(1) & "\"
End With
'In Case of Cancel
NextCode:
myPath = myPath
If myPath = "" Then GoTo ResetSettings
'Target File Extension (must include wildcard "*")
myExtension = "*.xls*"
'Target Path with Ending Extention
myFile = Dir(myPath & myExtension)
'Loop through each Excel file in folder
Do While myFile <> ""
'Set variable equal to opened workbook
Set wb = Workbooks.Open(Filename:=myPath & myFile)
'Ensure Workbook has opened before moving on to next line of code
DoEvents
'Change First Worksheet's Background Fill Blue
Application.Calculate
ActiveWorkbook.RefreshAll
Application.Wait (Now + TimeValue("0:00:10"))
'Save and Close Workbook
wb.Close SaveChanges:=True
'Ensure Workbook has closed before moving on to next line of code
DoEvents
'Get next file name
myFile = Dir
Loop
'Message Box when tasks are completed
MsgBox "Task Complete!"
ResetSettings:
'Reset Macro Optimization Settings
Application.EnableEvents = True
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
End Sub
Its probably an old question indeed, but still, I enjoyed writing it somehow. And in my solution, you get some nice printing in the console. Here you go:
Option Explicit
Function GetFiles(ByVal Folder As String) As Collection
Dim strFile As String
Set GetFiles = New Collection
strFile = Dir(Folder & "\*")
Do While strFile <> ""
GetFiles.Add strFile
strFile = Dir
Loop
End Function
Function GetFolders(ByVal Folder As String) As Collection
Dim strFile As String
Set GetFolders = New Collection
strFile = Dir(Folder & "\*", vbDirectory)
Do While strFile <> ""
If GetAttr(Folder & "\" & strFile) And vbDirectory Then GetFolders.Add strFile
strFile = Dir
Loop
End Function
Sub LoopThroughSubfoldersAsWell()
Dim colFoFi As Collection
Dim varEl01 As Variant
Dim varEl02 As Variant
Dim varEl03 As Variant
Dim strLine As String: strLine = "--------------------------"
Dim strAddress As String: strAddress = "C:\Users\UserName\Desktop\Testing01\"
Debug.Print strAddress
Set colFoFi = GetFiles(strAddress)
For Each varEl01 In colFoFi
Debug.Print varEl01
Next varEl01
Debug.Print strLine
Set colFoFi = GetFolders(strAddress)
For Each varEl01 In colFoFi
If Len(varEl01) > 2 Then 'to avoid some hidden stuff
Set varEl02 = GetFiles(strAddress & varEl01)
Debug.Print (strAddress & varEl01)
For Each varEl03 In varEl02
Debug.Print varEl03
Next varEl03
Debug.Print strLine
End If
Next varEl01
End Sub
I am running the following VBA in Ecel to open a folder and then update all Excel sheets within this folder. However I would like it to include all subfolders as well.
Sub AllWorkbooks()
Dim MyFolder As String 'Path collected from the folder picker dialog
Dim MyFile As String 'Filename obtained by DIR function
Dim wbk As Workbook 'Used to loop through each workbook
On Error Resume Next
Application.ScreenUpdating = False
'Opens the folder picker dialog to allow user selection
With Application.FileDialog(msoFileDialogFolderPicker)
.Title = "Please select a folder"
.Show
.AllowMultiSelect = False
If .SelectedItems.Count = 0 Then 'If no folder is selected, abort
MsgBox "You did not select a folder"
Exit Sub
End If
MyFolder = .SelectedItems(1) & "\" 'Assign selected folder to MyFolder
End With
MyFile = Dir(MyFolder) 'DIR gets the first file of the folder
'Loop through all files in a folder until DIR cannot find anymore
Do While MyFile <> “”
'Opens the file and assigns to the wbk variable for future use
Set wbk = Workbooks.Open(Filename:=MyFolder & MyFile)
'Replace the line below with the statements you would want your macro to perform
ActiveWorkbook.RefreshAll
Application.Wait (Now + TimeValue("0:00:05"))
wbk.Close savechanges:=True
MyFile = Dir 'DIR gets the next file in the folder
Loop
Application.ScreenUpdating = True
End Sub
Ok, you'll need to use the FileSystemObject and add a reference to the Windows Script Host Object Model in Tools->References. Then try the code below.
Sub AllWorkbooks()
Dim MyFolder As String 'Path collected from the folder picker dialog
Dim MyFile As String 'Filename obtained by DIR function
Dim wbk As Workbook 'Used to loop through each workbook
Dim FSO As New FileSystemObject ' Requires "Windows Script Host Object Model" in Tools -> References
Dim ParentFolder As Object, ChildFolder As Object
On Error Resume Next
Application.ScreenUpdating = False
'Opens the folder picker dialog to allow user selection
With Application.FileDialog(msoFileDialogFolderPicker)
.Title = "Please select a folder"
.Show
.AllowMultiSelect = False
If .SelectedItems.Count = 0 Then 'If no folder is selected, abort
MsgBox "You did not select a folder"
Exit Sub
End If
MyFolder = .SelectedItems(1) & "\" 'Assign selected folder to MyFolder
End With
MyFile = Dir(MyFolder) 'DIR gets the first file of the folder
'Loop through all files in a folder until DIR cannot find anymore
Do While MyFile <> ""
'Opens the file and assigns to the wbk variable for future use
Set wbk = Workbooks.Open(Filename:=MyFolder & MyFile)
'Replace the line below with the statements you would want your macro to perform
ActiveWorkbook.RefreshAll
Application.Wait (Now + TimeValue("0:00:05"))
wbk.Close savechanges:=True
MyFile = Dir 'DIR gets the next file in the folder
Loop
For Each ChildFolder In FSO.GetFolder(MyFolder).SubFolders
MyFile = Dir(MyFolder & ChildFolder.Name) 'DIR gets the first file of the folder
'Loop through all files in a folder until DIR cannot find anymore
Do While MyFile <> ""
'Opens the file and assigns to the wbk variable for future use
Set wbk = Workbooks.Open(Filename:=MyFolder & ChildFolder.Name & "\" & MyFile)
'Replace the line below with the statements you would want your macro to perform
ActiveWorkbook.RefreshAll
Application.Wait (Now + TimeValue("0:00:05"))
wbk.Close savechanges:=True
MyFile = Dir 'DIR gets the next file in the folder
Loop
Next ChildFolder
Application.ScreenUpdating = True
End Sub
Or, you can just use CMD and read the output, much faster for drilling down through subfolders.
I've used ".xl*" as the file filter (I assume you only want Excel files?) but change this as you see fit:
Sub MM()
Const startFolder As String = "C:\Users\MacroMan\Folders\" '// note trailing '\'
Dim file As Variant, wb As Excel.Workbook
For Each file In Filter(Split(CreateObject("WScript.Shell").Exec("CMD /C DIR """ & startFolder & "*.xl*"" /S /B /A:-D").StdOut.ReadAll, vbCrLf), ".")
Set wb = Workbooks.Open(file)
'// Do what you want here with the workbook
wb.Close SaveChanges:=True '// or false...
Set wb = Nothing
Next
End Sub
There is a ready script that counts number of rows in Workbooks from a selected folder. In case number of rows in any workbook is more than 1, this workbook is copied and saved into another folder.
Sub OpenFiles()
Dim MyFolder As String
Dim MyFile As String
Dim TargetWB As Workbook
MyFolder = GetFolder("C:\Users\user\Desktop")
MyFile = Dir(MyFolder & "*.*")
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Do While MyFile <> ""
Set TargetWB = Workbooks.Open(Filename:=MyFolder & "\" & MyFile & "*.*")
With TargetWB
If CountUsedRows(TargetWB) > 1 Then
.SaveAs "C:\Users\user\Desktop\vba\" & MyFile
End If
.Close
End With
MyFile = Dir
Loop
'Workbooks.Close savechanges:=False
Shell "explorer.exe C:\Users\user\Desktop\vba", vbMaximizedFocus
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub
Function GetFolder(strPath As String) As String
Dim fldr As FileDialog
Dim sItem As String
Set fldr = Application.FileDialog(msoFileDialogFolderPicker)
With fldr
.Title = "Select a Folder"
.AllowMultiSelect = False
.InitialFileName = strPath
If .Show <> -1 Then GoTo NextCode
sItem = .SelectedItems(1)
End With
NextCode:
GetFolder = sItem
Set fldr = Nothing
End Function
Function CountUsedRows(Wbk As Workbook) As Long
Dim WS As Worksheet
Set WS = Wbk.Sheets(1)
CountUsedRows = WS.Range("A" & Rows.Count).End(xlUp).Row
End Function
Is it possible to move a Worbook to another folder insted of coping it in case it contains more than 1 row.
And is it possible to use something like: Workbooks.Close savechanges:=False in order to close chosen Workbooks after rows counting? Thanks!
You can move a file easily using the MoveFile method of FileSystemObject object. To use this type with early binding add a reference to Microsoft Sripting Runtime in your VBA project.
I had a large number of doc files that I wanted to convert to docx files.
I discovered that there was not a really good way to automatically do this conversion.
I have submitted the method I used to do this but perhaps there are now other ways.
I found a few thing that might help:
Microsoft Bulk Converter
Simple Microsoft Word macro
However I was not satisfied with macro provided. I needed something recursive to also convert nested files. So I expanded it to do so.
Sub SaveAllAsDOCX()
'Search #EXT to change the extensions to save to docx
Dim strDocName As String
Dim strPath As String
Dim oDoc As Document
Dim fDialog As FileDialog
Dim intPos As Integer
'Create a folder dialog
Set fDialog = Application.FileDialog(msoFileDialogFolderPicker)
With fDialog
.Title = "Select root folder and click OK"
.AllowMultiSelect = False
.InitialView = msoFileDialogViewList
If .Show <> -1 Then
MsgBox "Cancelled By User", , "List Folder Contents"
Exit Sub
End If
'Select root folder
strPath = fDialog.SelectedItems.Item(1)
'Ensure the Folder Name ends with a "\"
If Right(strPath, 1) <> "\" Then strPath = strPath + "\"
End With
'Close any open documents
If Documents.Count > 0 Then
Documents.Close SaveChanges:=wdPromptToSaveChanges
End If
'remove any quotes from the folder string
If Left(strPath, 1) = Chr(34) Then
strPath = Mid(strPath, 2, Len(strPath) - 2)
End If
'begin recusion
recurse (strPath)
End Sub
'This method controls the recusion
Function recurse(folder As String)
'save all the files in the current folder
SaveFilesInFolder (folder)
'get all the subfolders of the current folder
Dim folderArray
folderArray = GetSubFolders(folder)
'Loop through all the non-empty elements for folders
For j = 1 To UBound(folderArray)
If folderArray(j) <> "" Then
'begin recusion on subfolder
recurse (folder & folderArray(j) & "\")
End If
Next
End Function
'Saves all files with listed extensions
Function SaveFilesInFolder(folder As String)
'List of extensions to look for #EXT
Dim strFilename As String
extsArray = Array("*.rtf", "*.doc")
'Loop through extensions
For i = 0 To (UBound(extsArray))
'select the 1st file with the current extension
strFilename = Dir(folder & extsArray(i), vbNormal)
'double check the current extension (don't to resave docx files)
Dim ext As String
ext = ""
On Error Resume Next
ext = Right(strFilename, 5)
If ext = ".docx" Or ext = "" Then
'Don't need to resave files in docx format
Else
'Save the current file in docx format
While Len(strFilename) <> 0
Set oDoc = Documents.Open(folder & strFilename)
strDocName = ActiveDocument.FullName
intPos = InStrRev(strDocName, ".")
strDocName = Left(strDocName, intPos - 1)
strDocName = strDocName & ".docx"
oDoc.SaveAs FileName:=strDocName, _
FileFormat:=wdFormatDocumentDefault
oDoc.Close SaveChanges:=wdDoNotSaveChanges
strFilename = Dir
Wend
End If
Next
strFilename = ""
End Function
'List all the subfolders in the current folder
Function GetSubFolders(RootPath As String)
Dim FS As New FileSystemObject
Dim FSfolder As folder
Dim subfolder As Variant
Set FSfolder = FS.GetFolder(RootPath)
'subfolders is variable length
Dim subfolders() As String
ReDim subfolders(1 To 10)
Dim i As Integer
i = LBound(subfolders)
For Each subfolder In FSfolder.subfolders
subfolders(i) = subfolder.Name
'increase the size of subfolders if it's needed
i = i + 1
If (i >= UBound(subfolders)) Then
ReDim subfolders(1 To (i + 10))
End If
Next subfolder
Set FSfolder = Nothing
GetSubFolders = subfolders
End Function
Yeah I know it's a lot of code. :)