I wrote a code where I want a user to select multiple files that code will loop through.
I can't get the loop to work as I am not defining the name right.
Sub RFPDataimporttest() 'select multiple files
Dim Files As Workbook
Dim Fname As Variant
Dim SrcWbk As Workbook
Dim DestWbk As Workbook
Dim i As Integer
Set DestWbk = ThisWorkbook
'choose files and define them as array
Fname = Application.GetOpenFilename(FileFilter:="Excel Files (*.xls*), *.xls*", Title:="Select alla RFP filer från leverantörer", MultiSelect:=True)
If IsArray(Fname) Then
For i = LBound(Fname) To UBound(Fname)
'this where i have a problem. how do i open each file in an array?
Set SrcWbk = Workbooks.Open(Fname)
SrcWbk.Sheets("1. General Information").Range("L8").Copy
With DestWbk.Worksheets("Sheet1").Cells(2, Columns.Count).End(xlToLeft).Offset(-1, 1)
.PasteSpecial Paste:=xlPasteColumnWidths
.PasteSpecial Paste:=xlPasteValues
End With
SrcWbk.Sheets("2. Product information").Range("Z1:AB91").Copy
With DestWbk.Worksheets("Sheet1").Cells(2, Columns.Count).End(xlToLeft).Offset(0, 1)
.PasteSpecial Paste:=xlPasteColumnWidths
.PasteSpecial Paste:=xlPasteValues
End With
SrcWbk.Close False
Next i
End If
End Sub
The result is an array - you are already checking that and looping over it. Simply use i as index:
Set SrcWbk = Workbooks.Open(Fname(i))
(note that the result is even an array when user selects only one file, so code will work for that case also)
Related
I'm trying to reduce redundancy in my macros but I'm struggling with getting an element from a jagged array and using it elsewhere.
The premise is a single workbook with many sheets being split by groups of sheet names into new documents that I can then send to the process owners so they only get their own data.
Previously I was selecting sheet names listed explicitly and pasting to a new document that was named explicitly, but I had to run 10 separate almost identical macros to do that and I have heard of select being a bad choice in many instances as well.
Below is my latest attempt, the first issue is at the printOut line I get a Type Mismatch.
Sub CopyOut()
Dim printOut, groupNames, Group1, groupArray() As Variant
Dim n, j As Long
Dim reNamed, fileName As String
Dim ws As Worksheet
Dim wb1, wb2 As Workbook
groupNames = Array("Group 1", "Group 2", "Group 3", "Group 4") 'other arrays left off for length
Group1 = Array("FA_1A Report", "FA_1A", "FA_2ACS Report", "FA_2ACS", "FA_2BCS Report", "FA_2BCS", "FANUCMED Report", "FANUCMED", "FA_RRTP1 Report", "FA_RRPT1")
groupArray = Array(groupNames, Group1)
For n = 1 To UBound(groupArray)
fileName = "CS Data Sheet" & " " & Format(Date, "mmmyy") & "-" & groupArray(n - n)(n - 1) & ".xlsm" 'concat file name string. this is not just tacked on the end of reName because i use it on it's own later
reNamed = "C:\Users\xx\Desktop\" & fileName 'concat save location string
Set wb1 = ThisWorkbook
Set wb2 = Workbooks.Add 'create a new workbook, wb2
wb2.SaveAs fileName:=reNamed, FileFormat:=xlOpenXMLWorkbookMacroEnabled 'save with that name and location
printOut = Join(Application.Index(groupArray, n, 0), ",")
wb1.Sheets(printOut).Copy Before:=Workbooks(fileName).Sheets(1) 'copy the sheets for the group and paste into the newly created document
Next
End Sub
If I nix printOut altogether and put in a specific worksheet name instead it does work for just that one sheet (of course) but I need it to copy multiple to each new document.
I have also tried:
For n = 1 To UBound(groupArray)
...
for j= LBound(groupArray(n)) To UBound(groupArray(n))
wb1.Sheets(groupArray(n)(j)).Copy Before:=Workbooks(fileName).Sheets(1)
next
next
to iterate through the subarray and copy a sheet at a time, but it gives subscript out of range. With this version I tried various methods of making the groupArray(n)(j) value into a string or into a "worksheet" type to set as a variable and use the variable in the sheets().copy, to no avail.
Any idea where I could be going wrong?
thanks so much
EDIT:
I got my above code working by wrapping it in split (was trying to use printOut as an array when it was only a string) and fixing the arguments of Index as below, however the resulting code still needs work, since if a sheet is missing it won't run.
printOut = Split(Join(Application.Index(groupArray(n), 1, 0), ","), ",")
In my experience, if you find yourself hard-coding values like sheet names, group names, and other data directly in your code it tends to become difficult to maintain. Adding more groups, or re-shuffling the sheets in each group becomes problematic. My recommendation is to create a (possibly hidden) worksheet that maps your worksheet names into groups. Then you have a small set of code that operates directly on that.
My example data is set up like this:
Next, in its own code module, I created a few methods to work directly with this group map data. The main idea here is to move the group map data into a memory-based array. While in general I rarely use module-level global variables, I have one in this example to illustrate how to work with the data by only reading it into the array once every time the macro is executed.
(These are Subs and Functions. For my own code, I likely would have created a VBA class to handle the data in an object-oriented way.)
So there is a Private Sub to get the data:
Option Explicit
Private groupData As Variant
Private Sub GetGroupData()
Const GROUP_WS_NAME As String = "GroupMap"
Dim ws As Worksheet
Set ws = ThisWorkbook.Sheets(GROUP_WS_NAME)
Dim lastRow As Long
Dim lastCol As Long
With ws
'--- how many columns of groups?
lastCol = .Cells(1, .Columns.Count).End(xlToLeft).Column
lastRow = .UsedRange.Find("*", , , , xlByRows, xlPrevious).Row
groupData = .Range("A1").Resize(lastRow, lastCol).Value
End With
End Sub
Now it's easy to figure out how many groups there are:
Public Function NumberOfGroups() As Long
If IsEmpty(groupData) Then GetGroupData
NumberOfGroups = UBound(groupData, 2)
End Function
And how many items in a particular group:
Public Function NumberInGroup(ByVal groupNumber As Long)
If IsEmpty(groupData) Then GetGroupData
'--- count the number of array values that have data
Dim i As Long
For i = LBound(groupData, 1) To UBound(groupData, 1)
If groupData(i, groupNumber) = vbNullString Then
'--- we found the first empty cell in this array, we're done
Exit For
Else
NumberInGroup = NumberInGroup + 1
End If
Next i
'--- subtract one to discount the header value
NumberInGroup = NumberInGroup - 1
End Function
The easiest of all is getting the value of any group:
Public Function GetGroupValue(ByVal groupNumber As Long, _
ByVal groupIndex As Long) As Variant
If IsEmpty(groupData) Then GetGroupData
'--- always add one to the index to account for the header value
GetGroupValue = groupData(groupIndex + 1, groupNumber)
End Function
Notice the check for If IsEmpty(groupData) Then GetGroupData at the beginning of each method. This makes sure the groupData array is always loaded if necessary.
This example gives it a quick test (in a different code module):
Option Explicit
Sub test()
Dim totalGroups As Long
totalGroups = NumberOfGroups()
Dim i As Long
Dim j As Long
For i = 1 To totalGroups
Dim totalInGroup As Long
totalInGroup = NumberInGroup(i)
For j = 1 To totalInGroup
Debug.Print "group " & i & " = " & GetGroupValue(i, j)
Next j
Next i
End Sub
Here's the whole group data code module in a single block:
Option Explicit
Private groupData As Variant
Private Sub GetGroupData()
Const GROUP_WS_NAME As String = "GroupMap"
Dim ws As Worksheet
Set ws = ThisWorkbook.Sheets(GROUP_WS_NAME)
Dim lastRow As Long
Dim lastCol As Long
With ws
'--- how many columns of groups?
lastCol = .Cells(1, .Columns.Count).End(xlToLeft).Column
lastRow = .UsedRange.Find("*", , , , xlByRows, xlPrevious).Row
groupData = .Range("A1").Resize(lastRow, lastCol).Value
End With
End Sub
Public Function NumberOfGroups() As Long
If IsEmpty(groupData) Then GetGroupData
NumberOfGroups = UBound(groupData, 2)
End Function
Public Function NumberInGroup(ByVal groupNumber As Long)
If IsEmpty(groupData) Then GetGroupData
'--- count the number of array values that have data
Dim i As Long
For i = LBound(groupData, 1) To UBound(groupData, 1)
If groupData(i, groupNumber) = vbNullString Then
'--- we found the first empty cell in this array, we're done
Exit For
Else
NumberInGroup = NumberInGroup + 1
End If
Next i
'--- subtract one to discount the header value
NumberInGroup = NumberInGroup - 1
End Function
Public Function GetGroupValue(ByVal groupNumber As Long, ByVal groupIndex As Long) As Variant
If IsEmpty(groupData) Then GetGroupData
'--- always add one to the index to account for the header value
GetGroupValue = groupData(groupIndex + 1, groupNumber)
End Function
If I got this right, you have one master workbook with n sheets and you want to group some of them, then create a new workbook for each group and paste in its assigned sheets.
I think an approach where you keep a "config" file in your master workbook for setting up groups and sheets, is more suitable rather than editing into code. Example:
The below code will create a file using the names from column A and copy all the sheets defined on their respective row.
Option Explicit
Sub CopyOut()
Dim groupArr() As Variant
Dim wb2 As Workbook
Dim lastRow As Long, lastCol As Long, highestNumOfSheets As Long, i As Long, j As Long, arrColumns As Long
Dim reNamed As String, fileName As String, configSheet As String
Dim removedSheet1 As Boolean
' Modify the sheet name here
configSheet = "config"
' Build an array from sheet defined groups
With ThisWorkbook.Worksheets(configSheet)
lastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
For i = 2 To lastRow
lastCol = .Cells(i, .Columns.Count).End(xlToLeft).Column
If lastCol > highestNumOfSheets Then highestNumOfSheets = lastCol
Next i
groupArr = .Range(.Cells(2, 1), .Cells(lastRow, highestNumOfSheets)).Value2
End With
Application.ScreenUpdating = False
For i = LBound(groupArr) To UBound(groupArr)
fileName = "CS Data Sheet " & Format(Date, "mmmyy") & "-" & groupArr(i, 1) & ".xlsm"
reNamed = Environ("UserProfile") & "\Desktop\" & fileName
removedSheet1 = False ' Reset this on each new workbook created
Set wb2 = Workbooks.Add
' Pick all the sheet names for the current group
For j = 2 To UBound(groupArr, 2)
' Skip empty values from array (if it's the case) and skip missing sheets
If Trim(groupArr(i, j)) <> vbNullString And SheetExists(groupArr(i, j)) Then
ThisWorkbook.Worksheets(groupArr(i, j)).Copy Before:=wb2.Worksheets(1)
' Remove Sheet1 from the new Workbook
If removedSheet1 = False Then
With Application
.DisplayAlerts = False
wb2.Worksheets("Sheet1").Delete
removedSheet1 = True
.DisplayAlerts = True
End With
End If
End If
Next j
' Here you might need an error handler if you think you're going to run the macro multiple times in the same day
' If the file exists already this will throw an error
' A quick lazy way is to add time (including seconds) when you define the file name above
wb2.SaveAs fileName:=reNamed, FileFormat:=xlOpenXMLWorkbookMacroEnabled
wb2.Close
If Not wb2 Is Nothing Then Set wb2 = Nothing
Next i
Application.ScreenUpdating = True
End Sub
Function SheetExists(ByVal sheetName As String) As Boolean
Dim ws As Worksheet
On Error Resume Next
Set ws = ThisWorkbook.Worksheets(sheetName)
On Error GoTo 0
If Not ws Is Nothing Then
SheetExists = True
Set ws = Nothing
End If
End Function
Of course it can be tweaked around, with error handling and other checks (depending on what you want to achieve entirely) but it should give you an alternative view of your code.
EDIT: Added a function to check if sheet exists.
I'm trying to create a single PDF file containing a sheet for each tab which I have listed from cell J2 in my Control sheet but I keep getting a Subscript Out Of Range error.
When I record the action I see that it creates an array of sheet names which it then selects to export, so I have a For loop which goes through the list and creates an array which adds to itself until it reaches the end of the list - the aim being to create one long string which I then select as an array.
All appears to be good (the variable PDFArray displays a string of the tab names in what appears to be the correct format) but when I get to the line 'Worksheets(Array(PDFarray)).Select' then I get the error. I've made sure the sheet names contain no undesirable characters or spaces but still no joy. Any help would be very much appreciated. Thank you
Sub B_PDFs()
Dim PDFarray As String, PDFName as String, sht As String
Sheets("Control").Select
PLFile = ActiveWorkbook.Name
PDFLoc = Application.ActiveWorkbook.Path & "\"
PDFName = Range("A20")
PDFSheetCount = Range("J1").Offset(Rows.Count - 1, 0).End(xlUp).Row
'Loop through column J and create a string with each tab name to be exported
For x = 2 To PDFSheetCount Step 1
If x = PDFSheetCount Then
sht = """ " & "" & Cells(x, 10) & """ "
Else
sht = """" & "" & Cells(x, 10) & """" & ", "
End If
PDFarray = PDFarray & sht
Next x
'Create PDF from the array above
Worksheets(Array(PDFarray)).Select - this is where I get the error Subscript Out Of Range
Selection.ExportAsFixedFormat Type:=xlTypePDF, Filename:=PFDLoc & PDFName, Quality:= _
xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas:=False,
OpenAfterPublish:=False
Workbooks(PLFile).Activate
End Sub
I don't understand why MS makes NOT requiring variable declaration the default. Select Tools/Options/Editor and check Require Variable Declaration. This will place Option Explicit at the start of any new module. To correct this module, enter it manually at the beginning.
Doing so would have enabled you to find and correct a typo in your code.
You should also be avoiding Select, Selection and Activate. They rarely serve any purpose at all, and can cause multiple problems because they lull into avoiding explicit declarations of which workbook, worksheet, etc. you need. See How to avoid using Select in Excel VBA
However in using the ExportAsFixedFormat method to export selected worksheets, it seems Selection and ActiveSheet are required for it to work.
Array(str_variable) returns an array with a single entry that contains the entire string variable. It does not interpret the string variable so as to split it into separate elements.
So, rewriting your code somewhat (I will leave it to you to clean up the PDF document):
Option Explicit
Sub B_PDFs()
Dim PDFarray As Variant, PDFName As String, PLFile As String, PDFLoc As String
Dim wsControl As Worksheet
Dim WB As Workbook
'Consider wheter you want to use ThisWorkbook or a specific workbook
Set WB = ThisWorkbook
With WB
Set wsControl = .Worksheets("Control")
PLFile = .Name
PDFLoc = .Path & "\"
End With
With wsControl
PDFName = .Range("A20")
'create PDFarray
'This will be a 1-based 2D array starting at J1
'If you need to start at J2, alter the initial cell
PDFarray = .Range(.Cells(1, 10), .Cells(.Rows.Count, 10).End(xlUp))
End With
'convert to a 1D array
PDFarray = WorksheetFunction.Transpose(PDFarray)
'Note the use of `Select` and `ActiveSheet` when using this `ExportAsFixedFormat` method
Worksheets(PDFarray).Select
'Create PDF from the array above
ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, Filename:=PDFLoc & PDFName, Quality:= _
xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas:=False, OpenAfterPublish:=False
End Sub
What #RonRosenfeld has suggested is correct about select and selection. The expression you are building is string whereas, Excel expects it to be real array.
So in principle an approach like below shall work for you which will create an array for processing and can be used as you want to utilise.
Dim shtNames As Variant
Dim pdfArray
shtNames = Range("J2:J" & Range("J1").Offset(Rows.Count - 1, 0).End(xlUp).Row).Value
pdfArray = Application.Transpose(shtNames)
Want to check if there is a worksheet with the same name as the file.
At the moment I have filnam opening the files as an array but want it to cycle through the code and see if there is a worksheet with the same name.
I have used a split to remove the path name and the extension but cant get it to check.
I apologise for the messiness of the code. Been trying to get it sorted then Ill tidy it up. There is more code but that isnt required for this as I want it to run that code if there isnt a match.
Please can you help?
Sub sort_it_out()
Dim wb1 As Workbook
Dim wb2 As Workbook
Dim Sheet As Worksheet
Dim filnam As Variant
On Error GoTo errorhandler
Set wb1 = ActiveWorkbook
ChDir Application.ActiveWorkbook.path
'get files
filnam = Application.GetOpenFilename(FileFilter:="2D Table Formats (*.htm;*.xlsm;*.html),*.htm;*.xlsm;*.html", Title:="Select 2D Table", MultiSelect:=True)
'set the array
If IsArray(filnam) Then 'if at least one file is selected, this will be an Array
'define j as the array
For j = LBound(filnam) To UBound(filnam)
'remove path and extension
Dim s As String, a() As String, p As String
s = filnam(j)
a() = Split(s, "\")
p = Split(a(UBound(a)), ".")(0)
MsgBox "p " & p
'check if worksheet exists
For Each ws_check In ThisWorkbook.Worksheets()
If ws_check.Name = p Then
MsgBox "Its there"
Exit Sub
Else
End If
Next ws_check
'continue code from here
This then runs the code... but its not looping the array for some reason. Only one file at at a time. Can you please help?
It is a little hard to follow your code but does this do what you are trying to do?
I think you were storing the file name in the p variable so my code below would check each worksheet in the workbook to see if they have the same name as the p variable.
Public Sub CompareWorksheetNamesToFiles()
Dim file_name As String
file_name = ActiveWorkbook.Name
Dim ws_check As Worksheet
For Each ws_check In ThisWorkbook.Worksheets()
If ws_check.Name = p Then
Debug.Print ("Do Something")
End If
Next ws_check
End Sub
I have worked it all out now.
This will now open file locations, shorten their paths to just the filename minus the extension, then ws check checks the sheets against the filename and then looper jumps to the next.
Thank you to alwaysdata for helping me out.
Sub sort_it_out()
Dim filnam As Variant
'open file locations
filnam = Application.GetOpenFilename(FileFilter:="2D Table Formats (*.htm;*.xlsm;*.html),*.htm;*.xlsm;*.html", Title:="Select 2D Table", MultiSelect:=True)
'if at least one file is selected, this will be an Array
If IsArray(filnam) Then
For j = LBound(filnam) To UBound(filnam)
'remove pathway and extension from entire filename and path. ie C:\open.txt becomes open.
Dim s As String, a() As String, p As String
s = filnam(j)
a() = Split(s, "\")
p = Split(a(UBound(a)), ".")(0)
'check if worksheet exists against p ... ie if theres a worksheet called open it will goto the next option if not it will continue through code
For Each ws_check In ThisWorkbook.Worksheets()
If ws_check.Name = p Then
MsgBox p & " has already been transfered across. ", vbExclamation 'lets the user know this is already there.
GoTo looper
Else
End If
Next ws_check
'do something here with the code if not found. IE MSGBOX " NOT FOUND "
'jump to this point if there is a match.
looper:
Next
Else
Exit Sub
End If
End Sub
I am trying to accomplish a simple task of merging PDF files to one PDF. And I want the resulting PDF file to have Bookmarks to each file from the filename. And preferably i would like to have a free solution for this.
I am on a windows system and want to execute this from either command line or even better from MSSQL.
The thing is that i will create PDF files of orders from an ERP system with Crystal Reports. An stored procedure will create these PDF files. After that i want to take selected PDFs and create a new merged PDF of those and the merged PDF should have each order number (from the filename) as a bookmark. So that you easily can jump to an order number if you are searching for a specific one.
And as I said preferably free solutions, if not available I am ready to code my own merge program in for example C# or similar.
I think you would need Adobe Acrobat for this, at a bare minimum. Or, if you don't have that and you don't want to pay for it, you can convert all PDFs to TXT files, and merge all TXT files. This sounds a bit cumbersome, but actually, the easiest thing to do . . . maybe . . . is to convert all those TXT files into Excel files, and merge those. That shouldn't be hard at all. Here is a script to convert all TXT files into Excel files.
Private Declare Function SetCurrentDirectoryA Lib _
"kernel32" (ByVal lpPathName As String) As Long
Public Function ChDirNet(szPath As String) As Boolean
'based on Rob Bovey's code
Dim lReturn As Long
lReturn = SetCurrentDirectoryA(szPath)
ChDirNet = CBool(lReturn <> 0)
End Function
Sub Get_TXT_Files()
'For Excel 2000 and higher
Dim Fnum As Long
Dim mysheet As Worksheet
Dim basebook As Workbook
Dim TxtFileNames As Variant
Dim QTable As QueryTable
Dim SaveDriveDir As String
Dim ExistFolder As Boolean
'Save the current dir
SaveDriveDir = CurDir
'You can change the start folder if you want for
'GetOpenFilename,you can use a network or local folder.
'For example ChDirNet("C:\your_path_here\")
'It now use Excel's Default File Path
ExistFolder = ChDirNet("C:\your_path_here\\Text\")
If ExistFolder = False Then
MsgBox "Error changing folder"
Exit Sub
End If
TxtFileNames = Application.GetOpenFilename _
(filefilter:="TXT Files (*.txt), *.txt", MultiSelect:=True)
If IsArray(TxtFileNames) Then
On Error GoTo CleanUp
With Application
.ScreenUpdating = False
.EnableEvents = False
End With
'Add workbook with one sheet
Set basebook = Workbooks.Add(xlWBATWorksheet)
'Loop through the array with txt files
For Fnum = LBound(TxtFileNames) To UBound(TxtFileNames)
'Add a new worksheet for the name of the txt file
Set mysheet = Worksheets.Add(After:=basebook. _
Sheets(basebook.Sheets.Count))
On Error Resume Next
mysheet.Name = Right(TxtFileNames(Fnum), Len(TxtFileNames(Fnum)) - _
InStrRev(TxtFileNames(Fnum), "\", , 1))
On Error GoTo 0
With ActiveSheet.QueryTables.Add(Connection:= _
"TEXT;" & TxtFileNames(Fnum), Destination:=Range("A1"))
.TextFilePlatform = xlWindows
.TextFileStartRow = 1
'This example use xlDelimited
'See a example for xlFixedWidth below the macro
.TextFileParseType = xlDelimited
'Set your Delimiter to true
.TextFileTabDelimiter = True
.TextFileSemicolonDelimiter = False
.TextFileCommaDelimiter = False
.TextFileSpaceDelimiter = False
'Set the format for each column if you want (Default = General)
'For example Array(1, 9, 1) to skip the second column
.TextFileColumnDataTypes = Array(1, 9, 1)
'xlGeneralFormat General 1
'xlTextFormat Text 2
'xlMDYFormat Month-Day-Year 3
'xlDMYFormat Day-Month-Year 4
'xlYMDFormat Year-Month-Day 5
'xlMYDFormat Month-Year-Day 6
'xlDYMFormat Day-Year-Month 7
'xlYDMFormat Year-Day-Month 8
'xlSkipColumn Skip 9
' Get the data from the txt file
.Refresh BackgroundQuery:=False
End With
ActiveSheet.QueryTables(1).Delete
Next Fnum
'Delete the first sheet of basebook
On Error Resume Next
Application.DisplayAlerts = False
basebook.Worksheets(1).Delete
Application.DisplayAlerts = True
On Error GoTo 0
CleanUp:
ChDirNet SaveDriveDir
With Application
.ScreenUpdating = True
.EnableEvents = True
End With
End If
End Sub
Currently have a working script that uses FSO, but it also opens .xlsm files within my working directory. I would like to to only open .txt files.
I found this code that should work, however I can't figure out how to apply it to my situation:
Sub test()
' Loop thru all files in the folder
folder = ActiveWorkbook.path
path = folder & "\*.txt"
Filename = Dir(path)
Do While Filename <> ""
'insert other functions here
Loop
End Sub
My Code (Works, but also opens .xlsm files, which I don't want it to do):
Option Explicit
Sub Initialize_barcode_lookup_Array_test()
Dim fso As FileSystemObject
Dim folder As String, path As String, count_txt_files As Long, Filename As String
Dim folder2 As folder
Dim file As file
Dim FileText As TextStream
Dim TextLine As String
Dim Items() As String
Dim ShippingPlanArray() As String
Dim i As Long, j As Long, k As Long
Dim cl As Range
Dim fName
Dim row As Long, column As Long
Dim shipping_plan As Long 'Number of shipping plans text files imported
Dim barcode_Lookup() As String
Dim lastRow As Long
Dim longest_lastRow As Long
Dim counter As Long
Dim FNSKU_Input As String
'<<<< Creating FSO Object >>>>>
'Define longest_lastRow
longest_lastRow = 0
'Define i (References the text file open)
i = 0
' Get a FileSystem object
Set fso = New FileSystemObject
' get the directory you want
Set folder2 = fso.GetFolder(ActiveWorkbook.path)
' Loop only while the files being opened are .txt files:
For Each file In folder2.Files
row = 0
column = 0
Set FileText = file.OpenAsTextStream(ForReading)
Do Until FileText.AtEndOfStream
fName = FileText.ReadLine
'Parse data by tabs (text-tab delimited) into Items() array
Items() = Split(fName, vbTab)
' Redimension Preserve the ShippingPlanArray()
' NOTE: You can only Redimension preserve the last dimension of a multi-dimensional array
' (In this case: row)
ReDim Preserve ShippingPlanArray(9, row)
'Read Data into an Array Variable
For column = LBound(Items) To UBound(Items)
'MsgBox Items(column)
ShippingPlanArray(column, row) = Items(column)
Next column
row = row + 1
Loop
Next file
End Sub
I don't know if fso support an overloaded method for GetFolder where you can specify the pattern. If it does, use that i.e. GetFolder(Path, "*.txt"). If it doesn't, can you not just add a simple condition to check the file extension in your 'for each' loop and only process the ones that ends in '.txt'.
Update:
Try this:
For Each file In folder2.Files
Dim extension As String
extension = LCase(Mid$(file, InStrRev(file, ".")))
If extension = ".txt" Then
Debug.Print "TEST"
End If
Next
I've tested it and it works as expected.