Initial Folder and Multiple Select (FileDialog) - excel

I have 2 problems regarding FileDialog.
The below code is to copy a file from another folder into another. But if it couldn't locate that file, it would open the FileDialog to select the file.
Problems:
When the FileDialog is opened, it would instead default to Documents and not the AltPath.
Is it possible to select 2 or more files with FileDialog without resorting to loop?
Dim fso As Object
Dim ws As Worksheet
Dim targetFile As Object
Dim S_Line As Long
Dim BasePath As String
Dim AltPath As String
Dim AltPath2 As String
Dim MainPath As String
Dim NewPath As String
Dim Position As String
Set fso = CreateObject("Scripting.FileSystemObject")
Set ws = ActiveSheet
BasePath = "Z:\Test\Folder\"
AltPath = "B:\Test\Folder\"
MainPath = BasePath & "File.xlsm"
NewPath = "D:\Folder\"
S_Line = 0
Position = UCase(Trim(ws.Cells(R_Line, 8).Value2))
If Position = "OK" Then
If Right(MainPath, 1) = "\" Then
MainPath = Left(MainPath, Len(MainPath) - 1)
End If
If fso.FileExists(MainPath) = True Then
fso.CopyFile Source:=MainPath, Destination:=NewPath
Else
Do While S_Line < 2
Set targetFile = Application.FileDialog(msoFileDialogFilePicker)
With targetFile
.Title = "Select a File"
.AllowMultiSelect = True
.InitialFolderName = AltPath
If .Show <> -1 Then
MsgBox "You didn't select anything"
Exit Sub
End If
AltPath2 = .SelectedItems(1)
End With
fso.CopyFile Source:=AltPath2, Destination:=NewPath
S_Line = S_Line + 1
Loop
End If

You did not answer my clarification question and your question is not so clear. Please, test the next code. It will open the dialog in the folder you need, and copy the selected items in the folder you want. I commented the lines being strictly connected to your environment (Position, S_Line), since I cannot deduce which are they and how to be used:
Sub copyFileSourceDest()
Dim fso As Object
Dim ws As Worksheet
Dim AltPath2 As String
Dim MainPath As String
Dim NewPath As String
Dim Position As String
Const AltPath As String = "B:\Test\Folder\"
Const BasePath As String = "Z:\Test\Folder\"
Set fso = CreateObject("Scripting.FileSystemObject")
Set ws = ActiveSheet
MainPath = BasePath & "File.xlsm"
NewPath = ThisWorkbook.path & "\NewFold\" ' "D:\Folder\"
'Position = UCase(Trim(ws.cells(R_Line, 8).Value2))
'If Position = "OK" Then
'the following sequence looks useless, since it is a FILE path:
'If Right(MainPath, 1) = "\" Then
' MainPath = left(MainPath, Len(MainPath) - 1)
'End If
If fso.FileExists(MainPath) = True Then
fso.CopyFile Source:=MainPath, Destination:=NewPath
Else
Dim item As Variant
With Application.FileDialog(msoFileDialogFilePicker)
.Title = "Select a File"
.AllowMultiSelect = True
'.InitialFolderName = AltPath 'it does not exist in this Dialog type
.InitialFileName = AltPath
If .Show <> -1 Then
MsgBox "You didn't select anything"
Exit Sub
End If
For Each item In .SelectedItems
AltPath2 = item
fso.CopyFile Source:=AltPath2, Destination:=NewPath
Next
End With
End If
'End If
End Sub
It will simple copy (all) files you select in the Dialog. Not understanding why necessary a loop as your code tried...

Related

To count tags in XML from folders and subfolders

The below mention code can successfully count the required tags in an XML files and also provides name of file and tag count in excel sheet. I have just one query that currently it only reads the folder individually. However if there are 300 folders in a parent folder i need to select each folder every time. Is there anyway if anyone can amend the code so that if there are 300 folders in a parent folder in read each and every file (XML) in all subfolders. This will be very helpful for me.
I have tried to do it my own but this is beyond my capacity.
Option Explicit
Sub process_folder()
Dim iRow As Long, wb As Workbook, ws As Worksheet, ar
Set wb = ThisWorkbook
Set ws = wb.Sheets(1)
ws.UsedRange.Clear
ws.Range("A1:C1") = Array("Source", "<Headline> Tag Count")
iRow = 1
' create FSO and regular expression pattern
Dim FSO As Object, ts As Object, regEx As Object, txt As String
Set FSO = CreateObject("Scripting.FileSystemObject")
Set regEx = CreateObject("VBScript.RegExp")
With regEx
.Global = True
.MultiLine = True
.IgnoreCase = True
.pattern = "<Headline>(.*)</Headline>"
End With
'Opens the folder picker dialog to allow user selection
Dim myfolder As String, myfile As String, n As Long
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
'Loop through all files in a folder until DIR cannot find anymore
Application.ScreenUpdating = False
myfile = Dir(myfolder & "*.xml")
Do While myfile <> ""
iRow = iRow + 1
ws.Cells(iRow, 1) = myfile
' open file and read all lines
Set ts = FSO.OpenTextFile(myfolder & myfile)
txt = ts.ReadAll
ts.Close
' count pattern matches
Dim m As Object
If regEx.test(txt) Then
Set m = regEx.Execute(txt)
ws.Cells(iRow, 2) = m(0).SubMatches(0) ' get date from first match
ws.Cells(iRow, 3) = m.Count
Else
ws.Cells(iRow, 2) = "No tags"
ws.Cells(iRow, 3) = 0
End If
myfile = Dir 'DIR gets the next file in the folder
Loop
' results
ws.UsedRange.Columns.AutoFit
Application.ScreenUpdating = True
End Sub
Use Subfolders property of the parent folder object.
Option Explicit
Sub process_folder()
Dim iRow As Long, wb As Workbook, ws As Worksheet, ar
Set wb = ThisWorkbook
Set ws = wb.Sheets(1)
ws.UsedRange.Clear
ws.Range("A1:B1") = Array("Source", "<Headline> Tag Count")
iRow = 1
' create FSO and regular expression pattern
Dim fso As Object, ts As Object, regEx As Object, txt As String
Set fso = CreateObject("Scripting.FileSystemObject")
Set regEx = CreateObject("VBScript.RegExp")
With regEx
.Global = True
.MultiLine = True
.IgnoreCase = True
.Pattern = "<Headline>(.*)</Headline>"
End With
'Opens the folder picker dialog to allow user selection
Dim myfolder, myfile As String, n As Long
Dim parentfolder As String, oParent
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
parentfolder = .SelectedItems(1) 'Assign selected folder to ParentFolder
End With
Set oParent = fso.getFolder(parentfolder)
' build collection or files
Dim colFiles As Collection
Set colFiles = New Collection
Call GetFiles(oParent, "xml", colFiles)
'Loop through all files in collection
Application.ScreenUpdating = False
For n = 1 To colFiles.Count
myfile = colFiles(n)
iRow = iRow + 1
ws.Cells(iRow, 1) = myfile
' open file and read all lines
Set ts = fso.OpenTextFile(myfile)
txt = ts.ReadAll
ts.Close
' count pattern matches
Dim m As Object
If regEx.test(txt) Then
Set m = regEx.Execute(txt)
ws.Cells(iRow, 2) = m(0).SubMatches(0) ' get date from first match
ws.Cells(iRow, 3) = m.Count
Else
ws.Cells(iRow, 2) = "No tags"
ws.Cells(iRow, 3) = 0
End If
' results
ws.UsedRange.Columns.AutoFit
Next
Application.ScreenUpdating = True
MsgBox colFiles.Count & " Files process", vbInformation
End Sub
Sub GetFiles(oFolder, ext, ByRef colFiles)
Dim f As Object
For Each f In oFolder.Files
If f.Name Like "*." & ext Then
colFiles.Add oFolder.Path & "\" & f.Name
End If
Next
' call recursively
For Each f In oFolder.subfolders
Call GetFiles(f, ext, colFiles)
Next
End Sub
Loop Through All Folders and Subfolders
In this post under the title Subfolder Paths to Collection, you can find the CollSubfolderPaths function, which will return the paths of all folders and their subfolders in a collection.
In your code, you could utilize it in the following way.
Sub process_folder()
' Preceding code...
Application.ScreenUpdating = False
' Return the paths of all folders and subfolders in a collection.
Dim MyFolders As Collection: Set MyFolders = CollSubfolderPaths(myfolder)
Dim Item As Variant
' Loop through the items in the collection.
For Each Item In MyFolders
' Get the first file.
myfile = Dir(Item & "\" & "*.xml")
'Loop through all files in a folder until DIR cannot find anymore
Do While myfile <> ""
' The same code...
Loop
Next Item
' results
ws.UsedRange.Columns.AutoFit
Application.ScreenUpdating = True
End Sub

How to get setting values from word files, and save them to an array?

I am a VBA noob and I am working on a script that would capture the header and footer settings of all word files in a folder. I would like to create an array, and save the values for header and footer for each file that can be found on the folder. I think I have managed to create the loop, however, I do not know how to save these values to an array.
Here is a sample of my script:
Option Explicit
Public savepath As String
'This will select the file/folder
Public Sub select_folder()
Dim Filepicker As FileDialog
Dim mypath As String
Set Filepicker = Application.FileDialog(msoFileDialogFolderPicker)
With Filepicker
.Title = "Select folder"
.AllowMultiSelect = False
.InitialFileName = Application.DefaultFilePath
.ButtonName = "Select(&S)"
If .Show = -1 Then
mypath = .SelectedItems(1) & "\"
Else
End
End If
End With
NextCode:
'select_folder = mypath
Set Filepicker = Nothing
savepath = mypath
End Sub
Sub excel_report()
Dim strFile As String
Dim strInFold As String
Dim extension As String
Dim WrdSrc As Word.document
Dim WrdApp As Word.Application
'count the files in the folder
strInFold = savepath
extension = "*.doc*"
strFile = Dir(strInFold & extension)
Do While strFile <> ""
counter = counter + 1
strFile = Dir
Loop
Dim arry(counter, 3) As Variant
'save values of files into an array
strInFold = savepath
extension = "*.doc*"
strFile = Dir(strInFold & extension)
Do While strFile <> ""
'open word application
On Error Resume Next
' Check whether Word is running
Set WrdApp = GetObject(, "Word.Application")
If WrdApp Is Nothing Then
' Word is not running, create new instance
Set WrdApp = CreateObject("Word.Application")
' For automation to work, Word must be visible
WrdApp.Visible = True
End If
On Error GoTo 0
DoEvents
' open file
Set WrdSrc = WrdApp.Documents.Open(filename:=strInFold & strFile)
'Add Array (arry) Values here
'assign strfile (file name) on column 1
'WrdSrc.Sections(1).Headers(wdHeaderFooterPrimary).Range on column 2
'WrdSrc.Sections(1).Footers(wdHeaderFooterPrimary).Range on column 3
'move to next row
Loop
End Sub
I am trying to achive an output that looks like this:
FileName HeaderValue FooterValue
testfile.doc ABCD Company Confidential Information
Testfile2.doc CDEF Company All rights reserved to CDEF company
And I would like to add this array to a new sheet, then add this sheet to the current workbook where this vba script is running.
How do we go about doing this?
Thank you in advance!

What is the error in my code that list all the tabs in a file?

I want my code to pick up a file (file 2) and then list out all the tabs in that file in my current spreadsheet ("Input_tab" from file1). The code is not making creating the list. What is the error in my code?
Sub ListSheets()
Dim FilePicker As FileDialog
Dim mypath As String
Dim sheet_count As Integer
Dim i As Integer
Dim ws As Worksheet
Set ws = ThisWorkbook.Sheets(Sheet1)
Set FilePicker = Application.FileDialog(msoFileDialogFilePicker)
With FilePicker
.Title = "Please Select a File"
.ButtonName = "Confirm"
.AllowMultiSelect = False
If .Show = -1 Then
mypath = .SelectedItems(1)
Else
End
End If
End With
Workbooks.Open Filename:=mypath
sheet_count = Sheets.Count
For i = 1 To sheet_count
ws.Cells(i, 1) = Sheets(i).Name
Next i
ActiveWorkbook.Close savechanges:=False
End Sub
When working with multiple workbooks (or really all the time) you should always be explicit about what (eg) Sheets collection you want to refer to (ie. in which workbook?)
This works for me
Sub ListSheets()
Dim mypath As String
Dim i As Long 'prefer Long over Integer
Dim ws As Worksheet, wb As Workbook
Set ws = ThisWorkbook.Sheets("Sheet1")
mypath = GetFilePath("Please Select a File", "Confirm")
If Len(mypath) = 0 Then Exit Sub
Application.ScreenUpdating = False 'hide opening workbook
Set wb = Workbooks.Open(Filename:=mypath, ReadOnly:=True) 'get a reference to the opened workbook
ws.Cells(1, 1).value = mypath '<<<
For i = 1 To wb.Sheets.Count
ws.Cells(i + 1, 1) = wb.Sheets(i).Name
Next i
wb.Close savechanges:=False
End Sub
'return user-selected file path
Function GetFilePath(TitleText As String, ButtonText As String) As String
With Application.FileDialog(msoFileDialogFilePicker)
.Title = TitleText
.ButtonName = ButtonText
.AllowMultiSelect = False
If .Show = -1 Then GetFilePath = .SelectedItems(1)
End With
End Function

Automation of reading data from multiple XML files

I've been trying to improve my code for a while now, but I can't get any further on my own.
I have a function that is executed via button press.
As it is, it only works with one file.
In the best case I could click a folder and the function would loop through the subfolders and read all XML files from all subfolders and would then enter the desired words in a table.
It would help me if I could read multiple XML files from a subfolder and not just one. Maybe then I can get further and get the other part right by myself.
This is my code so far:
Private Sub CommandButtonImport_Click()
Dim fd As Office.FileDialog
Set fd = Application.FileDialog(msoFileDialogFilePicker)
With fd
.Filters.Clear
.Title = "Select a XML File"
.AllowMultiSelect = True
If .Show = True Then
xmlFileName = .SelectedItems(1)
Dim xDoc As Object
Set xDoc = CreateObject("MSXML2.DOMDocument")
xDoc.async = False: xDoc.ValidateOnParse = False
xDoc.Load (xmlFileName)
Set Products = xDoc.DocumentElement
row_number = 1
Rows("11:11").Select
Selection.Insert Shift:=xlDown, CopyOrigin:=xlFormatFromRightOrBelow
For Each Product In Products.ChildNodes
Range("C11").Value = Products.ChildNodes(0).ChildNodes(0).Attributes.Item(21).Value
Range("F11").Value = Products.ChildNodes(0).ChildNodes(0).Attributes.Item(0).Value
Range("G11").Value = Products.ChildNodes(0).ChildNodes(0).ChildNodes(1).ChildNodes(0).Attributes.Item(1).Value
Range("C:C").Columns.AutoFit
row_number = row_number + 1
Next Product
End If
End With
Add_Row_Number
End Sub
I am not sure but this might Help
Any input can help and I would be very grateful thanks in advance RomanWASD
Use the getFolder method of a FileSystemObject to create a folder object. Then use Subfolders property and Files property in a recursive manner.
Option Explicit
Private Sub CommandButtonImport_Click()
Dim fd As Office.FileDialog, folder As String, n As Long
Set fd = Application.FileDialog(msoFileDialogFolderPicker)
With fd
.Filters.Clear
.Title = "Select a Folder"
.AllowMultiSelect = True
If .Show = True Then
folder = .SelectedItems(1)
Else
Exit Sub
End If
End With
Dim fso As Object, ws As Worksheet, t0 As Single: t0 = Timer
Set ws = ActiveSheet ' or better as Thisworkbook.Sheets("Name")
Set fso = CreateObject("Scripting.FileSystemObject")
' recurse down folder tree
n = n + ScanFolder(ws, fso.GetFolder(folder))
ws.Range("C:C").Columns.AutoFit
MsgBox n & " files scanned", vbInformation, Format(Timer - t0, "0.0 secs")
End Sub
Function ScanFolder(ws As Worksheet, folder As Object) As Long
Dim subfolder As Object, file As Object, n As Long
For Each subfolder In folder.SubFolders
n = n + ScanFolder(ws, subfolder) ' recurse
Next
For Each file In folder.Files
If file.Type = "XML Document" Then
ParseFile ws, file
n = n + 1
End If
Next
ScanFolder = n ' number of files
End Function
Function ParseFile(ws As Worksheet, file As Object)
Dim xDoc As Object, Products As Object
Set xDoc = CreateObject("MSXML2.DOMDocument")
With xDoc
.async = False
.ValidateOnParse = False
.Load file.Path 'folder and filename
Set Products = .DocumentElement
End With
If Products Is Nothing Then
Else
ws.Rows("11:11").Insert Shift:=xlDown, CopyOrigin:=xlFormatFromRightOrBelow
With Products.ChildNodes(0).ChildNodes(0)
ws.Range("C11").Value = .Attributes(21).NodeValue
ws.Range("F11").Value = .Attributes(0).NodeValue
ws.Range("G11").Value = .ChildNodes(1).ChildNodes(0).Attributes(1).NodeValue
End With
End If
End Function
I was recently dealing with a similar problem. The fastest solution I tried was to use import XML in VBA, import it as table and load table into array.
Sub xmlintoarray()
Dim FSO As Object
Dim FSOfile As Object
Dim wb As Workbook
Dim path As String
path = "C:\Documents\Studypool"
Set FSO = CreateObject("Scripting.FileSystemObject")
Set FSOfile = FSO.GetFolder(path)
Set FSOfile = FSOfile.Files
Set wb = ThisWorkbook
For Each FSOfile In FSOfile
wb.Sheets.Add.Name = FSOfile.Name
wb.XmlImport FSOfile.path, Importmap:=Nothing, overwrite:=True, _
Destination:=ThisWorkbook.Sheets(FSOfile.Name).Range("$A$1")
Next
'here insert code to merge tables
'create array from merged table
'or create merge arrays together.
End Sub

How do I copy a csv Sheet into an excel file without changes

I've got am csv file which looks as follows
When I select all cells and copy/paste it manually into another excel file the result is the same as the original. Howevever, trying to do the same in VBA gives me the following result.
This is the code I am using.
Sub test()
Dim arr1 As Object
Set arr1 = CreateObject("System.Collections.ArrayList")
Dim fldr As FileDialog
Dim sItem As String
Set fldr = Application.FileDialog(msoFileDialogFolderPicker)
With fldr
.Title = "Select"
.AllowMultiSelect = False
.InitialFileName = strPath
If .Show <> -1 Then GoTo NextCode
sItem = .SelectedItems(1)
End With
NextCode:
GetFolder = sItem
'-----------------------------------------------------------
Dim FileName As Variant
FileName = Dir(GetFolder & "\")
'-----------------------------------------------------------
While FileName <> ""
arr1.Add GetFolder & "\" & FileName
FileName = Dir
Wend
'-----------------------------------------------------------
Set fldr = Nothing
Dim i As Long
For i = 0 To arr1.Count - 1
'-------------------------------------------------------------------
Dim wkbk As Workbook
Set wkbk = Workbooks.Open(arr1(i))
wb1 = wkbk.Name
Set sht = wkbk.Worksheets(wkbk.Sheets(1).Name)
wkbk.Sheets(sht.Name).Copy After:=ThisWorkbook.Sheets("START")
ActiveSheet.Name = "NEW"
' MsgBox wkbk.Name
' ThisWorkbook.Sheets.Add.Name = "NEW"
' wkbk.Sheets(sht.Name).Cells.Copy
' ThisWorkbook.Sheets("NEW").Cells.Paste
wkbk.Close False
Next i
End Sub
Is there a way to get the same result as doing it manually?
Import CSV Files
Option Explicit
Sub importCSV()
Const InitialFolderPath As String = "F:\Test\2021"
Const FilePattern As String = "*.csv"
Dim dwb As Workbook: Set dwb = ThisWorkbook
Dim FolderPath As String
If Right(InitialFolderPath, 1) = "\" Then
FolderPath = InitialFolderPath
Else
FolderPath = InitialFolderPath & "\"
End If
Dim fd As FileDialog
Set fd = Application.FileDialog(msoFileDialogFolderPicker)
With fd
.Title = "Select"
.AllowMultiSelect = False
.InitialFileName = FolderPath
If .Show = False Then
MsgBox "You canceled."
Exit Sub
End If
FolderPath = .SelectedItems(1) & "\"
End With
Dim arl As Object: Set arl = CreateObject("System.Collections.ArrayList")
Dim FileName As String: FileName = Dir(FolderPath & FilePattern)
Do While FileName <> ""
arl.Add FolderPath & FileName
FileName = Dir
Loop
Application.ScreenUpdating = False
Dim swb As Workbook
Dim sws As Worksheet
Dim dws As Worksheet
Dim shId As Long
Dim i As Long
For i = 0 To arl.Count - 1
Set swb = Workbooks.Open(FileName:=arl(i), Local:=True)
Set sws = swb.Worksheets(1)
sws.Copy After:=dwb.Sheets(dwb.Sheets.Count)
Set dws = ActiveSheet
shId = shId + 1
On Error GoTo NewSheetError
dws.Name = "New" & shId
On Error GoTo 0
swb.Close False
Next i
'dwb.Save
Application.ScreenUpdating = True
Exit Sub
NewSheetError:
shId = shId + 1
Resume
End Sub

Resources