Excel Macro - Looping through files in a folder

[clappouk]

#Sub GetIP()

Dim DFWB As Workbook 'TM Tool
Dim NewWb As Workbook 'New Data sheet for all linked Ip addresess
Dim DataWb As Workbook 'TM Monitoring Spreadsheet
Dim DataWbs As Worksheet
Dim rtable As Range
Dim Flist As Worksheet
Dim NewWbs As Worksheet
Dim wkb As Workbook
Dim Tb As TextBox
Dim i As Integer

Set DFWB = ThisWorkbook
Set NewWb = Workbooks.Add(template:=xlWBATWorksheet)
' you must change the LookIn line of code to the Folder you wish to search
Set fs = Application.FileSearch
With fs
.LookIn = "Data Location"
.FileType = msoFileTypeExcelWorkbooks
If .Execute > 0 Then
For i = 1 To .FoundFiles.Count
Set DataWb = Workbooks.Open(.FoundFiles(i))

DFWB.Activate
DR = DataFm1.TextBox1.Value
Set NewWbs = NewWb.Worksheets(1)
Lastrow = NewWbs.Cells(Rows.Count, 2).End(xlUp).Row
Headln = Lastrow + 2
Nextrow = Headln + 1
Lastrow = Lastrow + 1
DataWb.Activate
If ActiveSheet.AutoFilterMode Then ActiveSheet.AutoFilterMode = False
Set DataWbs = Worksheets(1)
DataWbs.Range("A1").AutoFilter Field:=WorksheetFunction.Match("IPAddr", DataWbs.Rows(1), 0), Criteria1:=DR, Operator:= _
xlAnd

Set rtable = DataWbs.Range("A1").CurrentRegion

NewWbs.Cells(Headln, 1).Value = "FileName"
NewWbs.Cells(Headln, 1).Font.Bold = True
NewWbs.Cells(Headln, 1).Font.Size = 14
rtable.Copy Destination:=NewWbs.Cells(Nextrow, 1)
NewWbs.Cells(Headln, 2) = DataWb.Name
NewWbs.Cells(Headln, 2).Font.Size = 14
NewWbs.Cells(Headln, 2).Font.Bold = True

DataWb.Activate
If ActiveSheet.AutoFilterMode Then ActiveSheet.AutoFilterMode = False
ActiveWorkbook.Close SaveChanges:=False

Next i
End If
End With
NewWbs.Activate
NewWbs.Columns("A:K").AutoFit

For Each NewWbs In Worksheets
NewWbs.Range("A2:A" & NewWbs.Rows.Count).RowHeight = 20
Next NewWbs

Fname = Format(Now, "dd.mm.yyyy") & " " & "IPAddr " & DR & ".xls"
Location = "\\irf00969\Datafile\"
NewWb.SaveAs Filename:=Location & Fname

End Sub#

I have the above code that looks for an IP aaddres from multiple workbooks located in a folder, it then reports all instances to a new file.

I have highlighted some code above in RED I would like help with
1.
Message box the result of the foundfiles.count
Ask the user how many files they would like to use? Inputbox
only use the number of files requested from the inputbox
2.
We are in the process in migrating from Excel 2003 to Excel 2013, I belive .Filesearch will not work does anybody have a work around.

Thanks

Ray

 

[dmt32]

We are in the process in migrating from Excel 2003 to Excel 2013, I belive .Filesearch will not work does anybody have a work around.

One solution most use in place of FileSearch is to use Dir Function.

Not able to test but see if this update to your code works for you. I have added a version check to ensure correct file extension is used when migrate to newer version. Also, file format number will need to be specified when using SaveAs.

Change the Folder Path where shown in RED as required.

Sub GetIP()
    Dim DFWB As Workbook    'TM Tool
    Dim NewWb As Workbook    'New Data sheet for all linked Ip addresess
    Dim DataWb As Workbook    'TM Monitoring Spreadsheet
    Dim DataWbs As Worksheet
    Dim Flist As Worksheet
    Dim NewWbs As Worksheet
    Dim rtable As Range
    Dim Tb As TextBox




    Dim sFolder As String, sFile As String
    Dim FileExt As String
    Dim sFormat As Integer


    On Error GoTo myerror
    Set DFWB = ThisWorkbook
    Set NewWb = Workbooks.Add(template:=xlWBATWorksheet)




    If Val(Application.Version) < 12 Then
        sFormat = -4143
        FileExt = ".xls"
    Else
        sFormat = 51
        FileExt = ".xlsx"
    End If


    'Folder you are searching
    'change as required.
    sFolder = "C:\"


    sFile = Dir(sFolder & "*" & FileExt, vbDirectory)


    Application.ScreenUpdating = False


    Do While sFile <> ""
        If sFile <> ThisWorkbook.Name Then
            Set DataWb = Workbooks.Open(sFolder & sFile, ReadOnly:=True)


            DFWB.Activate
            DR = DataFm1.TextBox1.Value
            Set NewWbs = NewWb.Worksheets(1)
            Lastrow = NewWbs.Cells(Rows.Count, 2).End(xlUp).Row
            Headln = Lastrow + 2
            Nextrow = Headln + 1
            Lastrow = Lastrow + 1


            Set DataWbs = DataWb.Worksheets(1)


            With DataWbs
                If .AutoFilterMode Then .AutoFilterMode = False


                .Range("A1").AutoFilter Field:=WorksheetFunction.Match("IPAddr", .Rows(1), 0), Criteria1:=DR, Operator:= _
                                        xlAnd


                Set rtable = .Range("A1").CurrentRegion


            End With


            With NewWbs
                .Cells(Headln, 1).Value = "FileName"
                .Cells(Headln, 1).Font.Bold = True
                .Cells(Headln, 1).Font.Size = 14
                .Cells(Headln, 2) = DataWb.Name
                .Cells(Headln, 2).Font.Size = 14
                .Cells(Headln, 2).Font.Bold = True


                rtable.Copy Destination:=.Cells(Nextrow, 1)
            End With


            DataWb.Close False
        End If


        sFile = Dir
        Set DataWb = Nothing
    Loop


    NewWbs.Activate
    NewWbs.Columns("A:K").AutoFit


    For Each NewWbs In Worksheets
        NewWbs.Range("A2:A" & NewWbs.Rows.Count).RowHeight = 20
    Next NewWbs


    Fname = Format(Now, "dd.mm.yyyy") & " " & "IPAddr " & DR & FileExt
    Location = "\\irf00969\Datafile\"


    NewWb.SaveAs Filename:=Location & Fname, _
                 FileFormat:=sFormat, _
                 Password:="", _
                 WriteResPassword:="", _
                 ReadOnlyRecommended:=False, _
                 CreateBackup:=False
myerror:
    Application.ScreenUpdating = True
    If Err > 0 Then MsgBox (Error(Err)), 48, "Error"
End Sub

Hope Helpful

Dave

 

[clappouk]

Thanks Dave, Not yet tested but it looks good.

Will post further once tested

 

[clappouk]

Afternoon,

getting a Bad File Name error via Error Handling athe the following point in the code

sFolder = [COLOR=#ff0000][URL="file://\\irf00969\IPCases\Masterlists"]\\irf00969\IPCases\Masterlists[/URL] - Networks Address for shared folder[/COLOR]

    sFile = Dir(sFolder & "*" & FileExt, vbDirectory) - VbDirectory does show the correct count although this is where the code jumps to error handling

The code does not appear to identify the 1st spreadsheet in the folder & open?

Any ideas

Ray Clatworthy

 

[dmt32]

Try:

sFolder = \\irf00969\IPCases\Masterlists\</SPAN>

Dave