Wildcards and Looping

[BoRed79]

I have some code (see below) which is attempting to open each text file in a
folder (chosen by the user), save it as an excel file and then copy its
contents to a master file.

All of the files are named the same (i.e. 1.1 Name 1, 1.1 Name 2 etc etc),
so I want the macro to loop through the folder finding all of the files that
begin 1.1 and then perform the action. I think thought that I must be using
the wildcards incorrectly as the macro does not seem to be performing any
actions.

Can anyone advise where I might be going wrong.

Thanks.

Liz.


Code being used:

'32-bit API declarations (BT)
Declare Function SHGetPathFromIDList Lib "shell32.dll" _
Alias "SHGetPathFromIDListA" (ByVal pidl As Long, ByVal pszPath As String)
As Long

Declare Function SHBrowseForFolder Lib "shell32.dll" _
Alias "SHBrowseForFolderA" (lpBrowseInfo As BROWSEINFO) As Long

Public Type BROWSEINFO
hOwner As Long
pidlRoot As Long
pszDisplayName As String
lpszTitle As String
ulFlags As Long
lpfn As Long
lParam As Long
iImage As Long
End Type

Sub Provider()

'Switch off screen flashing

Application.ScreenUpdating = False

'Request the user to select the latest provider data

Msg = "Select the folder containing the latest PROVIDER data"
DDirectory = GetDirectory(Msg)
If DDirectory = "" Then Exit Sub
If Right(DDirectory, 1) <> "\" Then DDirectory = DDirectory & "\"

a = MsgBox(Prompt:=DDirectory, Buttons:=vbOKOnly)

'Open each text file, save it as an excel file and copy it into the analysis
model

ChDir DDirectory

Do While Filename = "1.1 *.txt"

Workbooks.OpenText Filename:="1.1 *.txt" _
, Origin:=xlMSDOS, StartRow:=1, DataType:=xlDelimited,
TextQualifier:= _
xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=True,
Semicolon:=False, _
Comma:=True, Space:=False, Other:=False, FieldInfo:=Array(Array(1,
1), _
Array(2, 1), Array(3, 1), Array(4, 1), Array(5, 1), Array(6, 1),
Array(7, 1), Array(8, 1), _
Array(9, 1), Array(10, 1), Array(11, 1), Array(12, 1), Array(13, 1),
Array(14, 1), Array(15 _
, 1), Array(16, 1)), TrailingMinusNumbers:=True

ActiveWorkbook.SaveAs Filename:=LocalFileName _
, FileFormat:=xlNormal, Password:="", WriteResPassword:="", _
ReadOnlyRecommended:=False, CreateBackup:=False

Range("A2").Select
Range(Selection, ActiveCell.SpecialCells(xlLastCell)).Select
Selection.Copy

Windows("Cancer monitoring (Provider).xls").Activate
Sheets("1.1 ReportDownload").Visible = True
Sheets("1.1 ReportDownload").Select
Sheets("1.1 ReportDownload").Range("B65536").End(xlUp).Offset(1,
-1).Select
ActiveSheet.Paste
Sheets("1.1 ReportDownload").Range("B65536").End(xlUp).Offset(1,
-1).Select
Sheets("1.1 ReportDownload").Visible = False
ActiveWorkbook.Save

Windows("1.1 *.xls").Activate
ActiveWorkbook.Close

Loop

Switch on screen flashing

Application.ScreenUpdating = True

End Sub
'More BT declarations
Function GetDirectory(Optional Msg) As String
Dim bInfo As BROWSEINFO
Dim path As String
Dim r As Long, x As Long, pos As Integer

' Root folder = Desktop
bInfo.pidlRoot = 0&

' Title in the dialog
If IsMissing(Msg) Then
bInfo.lpszTitle = "Select a folder."
Else
bInfo.lpszTitle = Msg
End If

' Type of directory to return
bInfo.ulFlags = &H1

' Display the dialog
x = SHBrowseForFolder(bInfo)

' Parse the result
path = Space$(512)
r = SHGetPathFromIDList(ByVal x, ByVal path)
If r Then
pos = InStr(path, Chr$(0))
GetDirectory = Left(path, pos - 1)
Else
GetDirectory = ""
End If
End Function

 

[ker_01]

One possible approach would be something like:

if Left(Filename,4) = "1.1 " then...

If you may have non-txt files that start with 1.1, then you could always
just limit your search to txt files (I don't have the code for this at my
fingertips, but you should be able to limit returned results) or just add an
"and" condition if you are returning a full filename including the extension:

if Left(Filename,4) = "1.1 " and Right(Filename, 4) = ".txt" then...

 

[Gary Brown]

This is what I would do....

Option Explicit
'==============================================
' Sub Purpose: Get the provider text file and make xls file
'
'==============================================
'
Public Sub GetProvider()
Dim blnSubFolders As Boolean
Dim k As Long, j As Long
Dim strArr() As String
Dim Filename As String
Dim LocalFileName As String
Dim strFileNameFilter As String
Dim varAnswer As String
Dim Msg As String
Dim strName As String
Dim strDirectory As String, strPath As String
Dim varSubFolders As Variant
Dim i As Long

On Error Resume Next

'- - - - V A R I A B L E S - - - - - - - - -
Filename = "1.1*.txt"
varSubFolders = vbNo
blnSubFolders = False
'- - - - - - - - - - - - - - - - - - - - - -

strFileNameFilter = _
InputBox( _
"Select the folder containing the latest PROVIDER data" _
& vbCr, _
"Enter file name to match:", Default:=Filename)

If Len(strFileNameFilter) = 0 Then
GoTo Exit_ListFiles
End If

Msg = "Select location of files to be " & _
"processed or press Cancel."

'Allow user to select folder(s)
With Application.FileDialog(msoFileDialogFolderPicker)
.AllowMultiSelect = False
.InitialFileName = Left(ActiveWorkbook.FullName, _
Len(ActiveWorkbook.FullName) - Len(ActiveWorkbook.Name))
.Title = Msg
.Show
strDirectory = .SelectedItems(1)
End With

If strDirectory = "" Then
Exit Sub
End If

If Right(strDirectory, 1) <> Application.PathSeparator Then
strDirectory = strDirectory & Application.PathSeparator
End If

'get 1st filename
strName = Dir(strDirectory & strFileNameFilter)

On Error Resume Next

'get # of files meeting correct filter
j = 0
Do While strName <> vbNullString
j = j + 1
strName = Dir()
Loop

ReDim strArr(1 To j)

'put filenames and file info into array
strName = Dir(strDirectory & strFileNameFilter)
k = 0
Do While strName <> vbNullString
k = k + 1
strArr(k) = strDirectory & strName
strName = Dir()
Loop

If k > 0 Then
For i = 1 To k
Workbooks.OpenText Filename:=strArr(i) _
, Origin:=xlMSDOS, StartRow:=1, DataType:=xlDelimited, _
TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, _
Tab:=True, Semicolon:=False, Comma:=True, Space:=False, _
Other:=False, FieldInfo:=Array(Array(1, 1), _
Array(2, 1), Array(3, 1), Array(4, 1), Array(5, 1), _
Array(6, 1), Array(7, 1), Array(8, 1), Array(9, 1), _
Array(10, 1), Array(11, 1), Array(12, 1), Array(13, 1), _
Array(14, 1), Array(15, 1), Array(16, 1)), TrailingMinusNumbers:=True

LocalFileName = Left(strArr(i), Len(strArr(i)) - 4)

ActiveWorkbook.SaveAs Filename:=LocalFileName _
, FileFormat:=xlNormal, Password:="", WriteResPassword:="", _
ReadOnlyRecommended:=False, CreateBackup:=False

Range("A2").Select
Range(Selection, ActiveCell.SpecialCells(xlLastCell)).Select
Selection.Copy

Windows("Cancer monitoring (Provider).xls").Activate
Sheets("1.1 ReportDownload").Visible = True
Sheets("1.1 ReportDownload").Select
Sheets("1.1 ReportDownload").Range("B65536"). _
End(xlUp).Offset(1, -1).Select
ActiveSheet.Paste
Sheets("1.1 ReportDownload").Range("B65536"). _
End(xlUp).Offset(1, -1).Select
Sheets("1.1 ReportDownload").Visible = False
ActiveWorkbook.Save

Windows("1.1 *.xls").Activate
ActiveWorkbook.Close

Next i
End If

Exit_ListFiles:
Application.StatusBar = False
Exit Sub

Err_ListFiles:
MsgBox "Error: " & Err & " - " & Err.Description
Resume Exit_ListFiles

End Sub

'==============================================


--
Hope this helps.
If it does, please click the Yes button.
Thanks in advance for your feedback.
Gary Brown