Hi,

I have tweaked a Macro that extracts data from workbooks within a given folder.

I have tried using the progress meters from links in this forum, but i could not make them to work.

what i need is a wait massage to show how many files in a folder and how many workbooks are being copied.

Can anyone help me with this problem.

Here's my Macro

Sub Extract_All()
    Dim wbSource As Workbook
    Dim wbThis As Workbook
    Dim rToCopy As Range
    Dim uRng   As Range
    Dim rNextCl As Range
    Dim lCount As Long
    Dim bHeaders As Boolean

    With Application
        .ScreenUpdating = False
        .DisplayAlerts = False
        .EnableEvents = False

        On Error Resume Next

        Set wbThis = ThisWorkbook
        'clear the range except  headers
        Set uRng = wbThis.Worksheets(1).UsedRange
        If uRng.Cells.Count <= 1 Then
            'no data in master sheet
            bHeaders = False
            GoTo search
        End If
        uRng.Offset(1, 0).Resize(uRng.Rows.Count - 1, _
                                 uRng.Columns.Count).Clear
search:
        With .FileSearch
            .NewSearch
            'Change path to suit
            .LookIn = "C:\DataBase"
            .FileType = msoFileTypeExcelWorkbooks

            If .Execute > 0 Then    'Workbooks in folder
                For lCount = 1 To .FoundFiles.Count    ' Loop through all.
                    'Open Workbook x and Set a Workbook  variable to it
                    Set wbSource = Workbooks.Open(Filename:=.FoundFiles(lCount), UpdateLinks:=0)
                    Set rToCopy = wbSource.Worksheets(1).UsedRange
                    Set rNextCl = wbThis.Worksheets(1).Cells(Rows.Count, 1).End(xlUp).Offset(1, 0)
                    If bHeaders Then
                        'headers exist so don't copy
                        rToCopy.Offset(1, 0).Resize(rToCopy.Rows.Count - 1, _
                                                    rToCopy.Columns.Count).Copy rNextCl
                        'no headers so copy
                        'place headers in Row 2
                    Else: rToCopy.Copy Cells(2, 1)
                        bHeaders = True
                    End If
                    wbSource.Close False     'close source workbook
                Next lCount
            Else: MsgBox "No workbooks found"
            End If
        End With


        On Error GoTo 0
        .ScreenUpdating = True
        .DisplayAlerts = True
        .EnableEvents = True
    End With
End Sub
Thanks

Panic