VBA Application.Filesearch workaround

[eeder1]

I REALLY need a fix for the application.filesearch function that is currently in some old code which works in Excel 2003 and before but not in Excel 2007. I have heard suggestions on fixing this by using the Dir function but with my limited knowledge and no time I need expertise...PLEASE HELP!!!!



Call GetBrowse 'goes to a sub that allows you to pick a file with multiple excel files...after running through it jumps back to the Application.Filesearch below and gets stuck due to it being removed from 2007
With Application.FileSearch
.NewSearch
.LookIn = strPath
.Filename = "*.xls"
If .Execute() > 0 Then
Workbooks.Add
WrWrkBk = ActiveWorkbook.Name
x = Workbooks(WrWrkBk).Worksheets.Count

sort = 8
For i = 1 To counter - 1
Application.ScreenUpdating = False
strfile = .FoundFiles(i)


Find_Last_Slash (strfile)
strfile = Mid(strfile, 1, position)
a = a + 1
strDiv = Workbooks(RdWrkBk1).Sheets(1).Cells(a, sort).Value
strfile = strfile & strDiv & ".xls"

Workbooks.Open strfile 'open workbook

Find_Last_Slash (strfile)
RdWrkBk = Trim(Mid(strfile, position + 1, 50))

 

[eeder1]

I think that got jumbled

No each file name has it's own cell

H7 = Texas
H8 = Florida
H = New York

something must be missing in the code to pick up the r.value?

 

[jindon]

try

Sub test()
Dim myFolder As String, fn As String, wb As Workbook
Dim mySheet As String, myRange As String, r As Range, rng As Range
Dim myRows As Long, myCols As Long, n As Long
With Application.FileDialog(msoFileDialogFolderPicker)
    If .Show = True Then
        myFolder = .SelectedItems(1)
    Else
        Exit Sub
    End If
End With
myFolder = myFolder & "\"
mySheet = "Unit Waterfalls" '← Alter here to suite (common sheet name)
myRange = "A1:Z100"  '← You Must Alter here (range to be extracted)
With Range(myRange)
    myRows = .Rows.Count
    myCols = .Columns.Count
End With
Set wb = Workbooks.Add
With ThisWorkbook.Sheets(1)
    Set rng = .Range("h7", .Range("h" & Rows.Count).End(xlUp))
End With
For Each r In rng
    fn = Dir(myFolder & r.Value & ".xls", vbNormal)
    If fn = "" Then
        MsgBox "No such file named " & r.Value & ".xls in " & myFolder
    Else
        n = n + 1
        If n > wb.Sheets.Count Then wb.Sheets.Add after:=wb.Sheets(n-1)
        With wb.Sheets(n).Cells(1).Resize(myRows, myCols)
            .Formula = "='" & myFolder & "[" & fn & "]" & mySheet & "'!" & Split(myRange,":")(0)
            .Value = .Value
        End With
        wb.Sheets(n).Name = r.Value & "- Unit Waterfalls"
    End If
Next
End Sub

 

[eeder1]

Ok, getting closer..creates a new file, add a sheets, copies the first file from the list data(not in the same format but worry about that later) then it gives me a update links pop up (at red section below) then does not move on to the next file or name the worksheet

Sub test()
Dim myFolder As String, fn As String, wb As Workbook
Dim mySheet As String, myRange As String, r As Range, rng As Range
Dim myRows As Long, myCols As Long, n As Long
With Application.FileDialog(msoFileDialogFolderPicker)
If .Show = True Then
myFolder = .SelectedItems(1)
Else
Exit Sub
End If
End With
myFolder = myFolder & "\"
mySheet = "Unit Waterfalls" '? Alter here to suite (common sheet name)
myRange = "A1:Z36" '? You Must Alter here (range to be extracted)
With Range(myRange)
myRows = .Rows.Count
myCols = .Columns.Count
End With
Set wb = Workbooks.Add
With ThisWorkbook.Sheets(1)
Set rng = .Range("h7", .Range("h" & Rows.Count).End(xlUp))
End With
For Each r In rng
fn = Dir(myFolder & r.value & ".xls", vbNormal)
If fn = "" Then
MsgBox "No such file named " & r.value & ".xls in " & myFolder
Else
n = n + 1
If n > wb.Sheets.Count Then wb.Sheets.Add after:=wb.Sheets(n - 1)
With wb.Sheets.Cells(1).Resize(myRows, myCols)
.Formula = "='" & myFolder & "[" & fn & "]" & mySheet & "'!" & Split(myRange, ":")(0) 'asks if you want to update links since the file was not updated upon last save i do nothave links in that file?
.value = .value
End With
wb.Sheets.Name = r.value & "- Unit Waterfalls"
End If
Next
End Sub

 

[jindon]

Please wrap the code with the code tag from next time on, otherwise I will not read it.

Does the list start from H6 as you stated ?

If the loop doesn't go next cell then something is wrong with the list.

not in the same format but worry about that later

If you want it as exactly the same as it looks, like cell format, then you need to actually open each files and copy the range.
You should tell it from the first stage.

 

[eeder1]

Please wrap the code with the code tag from next time on, otherwise I will not read it. Sorry never tried that before..will try

Does the list start from H6 as you stated ? H7:H50

If the loop doesn't go next cell then something is wrong with the list.


If you want it as exactly the same as it looks, like cell format, then you need to actually open each files and copy the range.
You should tell it from the first stage.

Yes, that is how it was done before when I would watch it run

 

[jindon]

Sub test()
Dim myFolder As String, fn As String, wb As Workbook, n As Long
Dim mySheet As String, myRange As String, r As Range, rng As Range
With Application.FileDialog(msoFileDialogFolderPicker)
    If .Show = True Then
        myFolder = .SelectedItems(1)
    Else
        Exit Sub
    End If
End With
myFolder = myFolder & "\"
mySheet = "Unit Waterfalls"
myRange = "A1:Z100"
Set wb = Workbooks.Add
With ThisWorkbook.Sheets(1)
    Set rng = .Range("h7", .Range("h" & Rows.Count).End(xlUp))
End With
For Each r In rng
    fn = Dir(myFolder & r.Value & ".xls", vbNormal)
    If fn = "" Then
        MsgBox "No such file named " & r.Value & ".xls in " & myFolder
    Else
        n = n + 1
        If n > wb.Sheets.Count Then wb.Sheets.Add after:=wb.Sheets(n-1)
        With Workbooks.Open(myFolder & fn)
            .Sheets(mySheet).Range(myRange).Copy
            wb.Sheets(n).Cells(1).PasteSpecial
            wb.Sheets(n).Cells.Value = wb.Sheets(n).Cells.Value
            Application.CutCopyMode = False
            .Close False
        End With
    End If
    wb.Sheets(n).Name = r.Value & " - Unit Waterfalls"
Next
End Sub

 

[eeder1]

<?xml:namespace prefix = o ns = "urn:schemas-microsoft-comfficeffice" /><o> Giving me a compile error at </o>

value

<o></o>

<o> </o>
.Sheets(mySheet).Range(myRange).Copy _
wb.Sheets.Cells(1).PasteSpecial xlPasteValues

 

[eeder1]

            .Sheets(mySheet).Range(myRange).Copy _
            wb.Sheets(n).Cells(1).PasteSpecial xlPasteValues

 

[jindon]

Code has been edited

 

[eeder1]

Ok that copy paste specials the data (loses the coloring but least of my worries) It still only grabs one file data and then stops. this time the update link did not pop up ..Still need to name worksheet and grab multiple files..any more thoughts? Once again much appreciated