get dir list or open files sequentialy

Posted by John on January 24, 2002 10:18 AM

I would like to open files in a specific directory one at a time, strip the data and then close and move the file to another directory. Is there a way to do this. If not is there a way to do this how can I make a list of files in a directory?

Thanks,

John

Posted by Bariloche on January 24, 2002 7:31 PM

John,

This subroutine, modified to your specifics, should get you going:

Dim File() As String
Dim FoundFile As String
Dim FileCount As Integer
Dim strDataBookName As String
Dim strConsolidatedBook As String
Dim intLastRow As Double
Dim strTemp As StringSub ConsolidateData()
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False

    FoundFile = Dir("C:\MyDocuments\*.xls")

    FileCount = 1
    ReDim Preserve File(FileCount)
    File(FileCount) = FoundFile
    Do While FoundFile &LT;&GT; ""
        FoundFile = Dir()
        If FoundFile &LT;&GT; "" Then
            FileCount = FileCount + 1
            ReDim Preserve File(FileCount)
            File(FileCount) = FoundFile
        End If
    Loop

    ChDir "C:\MyDocuments\"
    Workbooks.Open File(1)
    strDataBookName = ActiveWorkbook.Name
    Workbooks.Add
    strConsolidatedBook = ActiveWorkbook.Name
    Workbooks(strDataBookName).Sheets("Sheet1").Range(Cells(1, 1), Cells(9, 32)).Copy
    Workbooks(strConsolidatedBook).Paste
    Application.CutCopyMode = False
    Rows(9).Hidden = True
    intLastRow = Workbooks(strDataBookName).Sheets("Sheet1").Cells(65536, 2).End(xlUp).Row
    Workbooks(strDataBookName).Sheets("Sheet1").Range(Cells(1, 10), Cells(intLastRow, 32)).Copy

    For i = 2 To FileCount
        Workbooks.Open File(i)
        strTemp = ActiveWorkbook.Name
        Range(Cells(1, 1), Cells(1, 1).End(xlDown)).Copy
        Workbooks(strDataBookName).Activate
        Cells(i, 2).PasteSpecial Paste:=xlValues, Transpose:=True
        Application.CutCopyMode = False
        Workbooks(strTemp).Close
        Cells(i, 1).Value = Left(File(i), Len(File(i)) - 4)
    Next i
    Cells(1, 1).Select
    Application.Dialogs(xlDialogSaveAs).Show

    Application.ScreenUpdating = True
    Application.DisplayAlerts = True
End Sub

have fun