Pulling data from external files

[Ade]

Hi all,

I have 12 external files (one per month) and need a quick way to pull these into a reporting book. I've used the following code...

Workbooks.Open FileName:= _
"J:\Manfin\MIS\New Reporting\MIS2\P200301.xls"
Columns("A:B").Select
Selection.Copy
Windows("MainReportingBook.xls").Activate
Sheets("P200301").Select
Range("A1").Select
ActiveSheet.Paste
Windows("P200301.xls").Activate
Call OpenClipboard(0&): Call EmptyClipboard: Call CloseClipboard
ActiveWindow.Close

However with 10000++ rows of data in each file, this is very very slow (approx 5 mins to update all 12 months).

As a complete newbie to vb, I started by recording then amending the code - but now I need some help!

Any quick fix ideas would be greatly appreciated. I found some code on ozgrid.com to extract data without opening the file - but couldn't get it to work - my fault as I wasn't sure which bits to overwrite with my own filenames etc etc.

Thanks in advance!

Ade

 

[tusharm]

Do the source files have formulas that need updating? If so, there's probably not much that can be done to speed up processing.

Or does the main workbook have some kind of a summary sheet that needs updating after each copy statement is executed? If so, use a Application.Calculation=xlManual before the first file is processed and after the last files et it back to whatever it was.

Are the source files on a network server? If so, that might be the cause of the slow processing.

Finally, and this won't help with speed, but it sure cleans up the code. Use a macro with parameters to streamline the code. This is a simple and very effective technique overlooked by many, including experienced developers.

Option Explicit
    Sub importOneFile(whatFile As String, TargetSheet As Worksheet)
        Dim WB As Workbook
        Application.StatusBar = "Copying " & whatFile
        Set WB = Workbooks.Open(whatFile, , True)
        TargetSheet.Range("A1:B20000").Value = Range("A1:B20000").Value
        WB.Close
        Set WB = Nothing
        Application.StatusBar = False
        End Sub
Sub DataImport2()
    Dim main As Workbook, mthID As Long, SavedCalcValue
    Const myDir As String = "J:\Manfin\MIS\New Reporting\MIS2\"
    Application.ScreenUpdating = False
    SavedCalcValue = Application.Calculation
    Application.Calculation = xlCalculationManual
    Set main = Workbooks("MainReportingBook(Ade2).xls")
    For mthID = 200301 To 200303
        importOneFile myDir & "P" & CStr(mthID) & ".xls", main.Sheets("P" & CStr(mthID))
        Next mthID
    Application.ScreenUpdating = True
    Application.Calculation = SavedCalcValue
    End Sub

 

[Legacy 98055]

A lot of code to save you five minutes a month but I thought I could learn something here. This imported 12 files with 12000 + rows in under three seconds on a mediocre machine. Win 2000, AMD 1.4, 256 DDR ram. It accounts for pre 2000 versions of Excel which do not have the CopyFromRecordset method. Surprisingly, in this case, the method I chose for earlier versions is a bit faster than the CopyFromRecordset method. Paste this code into your workbook and run "CallImport". Browse to a folder which contains your source files. It is assumed that this folder contains nothing else but your source files. Choose any one of your source files to gather the folder's path. The worksheets will be added dynamically based upon the name of each file read. Seeing that you are new to VBA, I used late binding but noticed very little difference in performace though early binding was a tad bit faster.

Public Sub CallImport()

    Dim strGetFolder As String
    Dim fsoFileSystemObj As Object
    Dim fsoFile As Object
    Dim strSheetName As String
    Dim sh As Worksheet
    Dim strFileName As String
    
    On Error GoTo err_CallImport
    'browse for one of the files which will be imported
    strGetFolder = Application.GetOpenFilename
    'Exit procedure if user cancels
    If strGetFolder = "False" Then Exit Sub
    'extract the folder name by removing the filename
    strGetFolder = Left(strGetFolder, InStrRev(strGetFolder, "\") - 1)
    'loop through the folder and process each file
    Set fsoFileSystemObj = CreateObject("Scripting.FileSystemObject")
    'loop through the folder querying each file
    Application.ScreenUpdating = False
    For Each fsoFile In fsoFileSystemObj.GetFolder(strGetFolder).Files
        'build the individual worksheet names using the current file
        strSheetName = Left(fsoFile.Name, InStrRev(fsoFile.Name, ".") - 1)
        'if the sheet does not exist, then it will be added to this workbook
        If Not SheetExists(strSheetName) Then
            Set sh = ThisWorkbook.Sheets.Add
            sh.Name = strSheetName
        End If
        'call the import function which will return TRUE of FALSE
        If Import(fsoFile.Path, Sheets(strSheetName).Cells(1, 1)) Then
            'no errors
        Else
            MsgBox "Problem"
        End If
    Next
    Application.ScreenUpdating = True
    Set fsoFile = Nothing: Set fsoFileSystemObj = Nothing
    Set sh = Nothing: Set fsoFile = Nothing
Exit Sub
err_CallImport:
MsgBox Err.Description, vbCritical, "Sub CallImport"
On Error Resume Next
Set fsoFile = Nothing: Set fsoFileSystemObj = Nothing
Set sh = Nothing: Set fsoFile = Nothing
End Sub

Private Function Import( _
    WbPath As String, _
    DestinationRange As Range _
    ) As Boolean
    
    On Error GoTo err_Import
    
    Dim rs As Object
            
    Set rs = CreateObject("ADODB.Recordset")
    
    rs.Open "[Sheet1$]", "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & _
        WbPath & "; Extended Properties=""Excel 8.0;HDR=No""", 3, 1, 2
    
    'determine office version and compile code accordingly
    'the CopyToRecordset method is available from 2000/9.0 and later
    'the worksheet function "Transpose" imposes some limitations
    'which bring the need for a workaraound
    #If Version > 8 Then
        DestinationRange.CopyFromRecordset rs
    #Else
        Dim vntArr As Variant
        Dim lngRow As Long
               
        rs.MoveFirst
        lngRow = 1
        
        Do
            vntArr = rs.GetRows(1000)
            vntArr = Application.WorksheetFunction.Transpose(vntArr)
            
            With DestinationRange.Parent
                .Range(.Cells(lngRow, 1), _
                    .Cells(lngRow + UBound(vntArr, 1) - 1, UBound(vntArr, 2))) = vntArr
            End With
            lngRow = lngRow + UBound(vntArr, 1)
            Erase vntArr
        Loop While Not rs.EOF
        
        Erase vntArr
    #End If

    rs.Close
    Set rs = Nothing
    
    Import = True
    
Exit Function
err_Import:
    MsgBox Err.Description, vbCritical, "Function Import"
    On Error Resume Next
    Set rs = Nothing
    Exit Function
   
End Function

Private Function SheetExists( _
    SheetName As String _
    ) As Boolean

    On Error GoTo err_SheetExists
    
    Dim sh As Worksheet
    
    For Each sh In ThisWorkbook.Sheets
        If sh.Name = SheetName Then
            SheetExists = True
            Set sh = Nothing
            Exit Function
        End If
    Next
    Set sh = Nothing

Exit Function
err_SheetExists:
MsgBox Err.Description, vbCritical, "Function SheetExists"
On Error Resume Next
Set sh = Nothing
End Function

Tom

 

[Ade]

Well I've finally completed what I set out to achieve - using Tushars code (cos it looked particularly impressive! lol), the load is now down to about 1m30s - which I'm more than happy with. As I say it wasn't the fact it was taking 5 mins, it's the fact that the users may have to repeat this up to 20 times per month, so possible load tiems have been reduced from a total of about 1hr40mins per month - to just 30 mins per month.

I also used the looping on some fnid/replaces that I needed to do to, so 2 birds with one stone here!

Thanks for your help everyone

 

[rwhiton]

Another data sharing alternative

Sharing Excel data with others can be difficult (especially when you want to keep the data current). You might try out http://www.linkedcells.com. It is a product that makes it really easy to share Excel data with others. You data is kept up to date in a publish/subscribe fashion.[/url]

 

[truongvan78]

Hi Tusharm, I am a newer in this so could you let me know if the code will collect new updated data only or it will collect all data in the users sheets?