Search code examples
excelvbaexternal

Copy more than one range of data from a closed workbook


What I am hoping to accomplish, is to copy select ranges of data from a closed workbook(Column D,H,Q and R) and paste them in the active workbook(Workbook with code below). The code below completes that but it displays "NULL" for values that it should not. For example, I am copying currencies (USD, CAD, GBP) which are all non-numbers and a portion of them display "NULL". One other objective is to have the ranges of data copied to be displayed like the closed workbook(in the order of the closed workbook) For example column A displays an entity and all the columns to the right show data for that entity.

Sub GetData_Example4()
Dim SaveDriveDir As String, MyPath As String
Dim FName As Variant

SaveDriveDir = CurDir
MyPath = Application.DefaultFilePath    'or use "C:\Data"
ChDrive MyPath
ChDir MyPath
FName = Application.GetOpenFilename(filefilter:="Excel Files, *.xl*")

If FName = False Then
    'do nothing
Else
    GetData FName, "Sheet1", "D1:D10000", Sheets("Sheet1").Range("A1"), 
False, False
    GetData FName, "Sheet1", "H1:H10000", Sheets("Sheet1").Range("B1"), 
False, False
    GetData FName, "Sheet1", "Q1:Q10000", Sheets("Sheet1").Range("C1"), 
False, False
    GetData FName, "Sheet1", "R1:R10000", Sheets("Sheet1").Range("D1"), 
False, False
End If

ChDrive SaveDriveDir
ChDir SaveDriveDir
End Sub

Below is the code for "GetData"

Public Sub GetData(SourceFile As Variant, SourceSheet As String, _
SourceRange As String, TargetRange As Range, Header As 
Boolean, UseHeaderRow As Boolean)

Dim rsCon As Object
Dim rsData As Object
Dim szConnect As String
Dim szSQL As String
Dim lCount As Long

' Create the connection string.
If Header = False Then
    If Val(Application.Version) < 12 Then
        szConnect = "Provider=Microsoft.Jet.OLEDB.4.0;" & _
                    "Data Source=" & SourceFile & ";" & _
                    "Extended Properties=""Excel 8.0;HDR=No"";"
    Else
        szConnect = "Provider=Microsoft.ACE.OLEDB.12.0;" & _
                    "Data Source=" & SourceFile & ";" & _
                    "Extended Properties=""Excel 12.0;HDR=No"";"
    End If
    Else
    If Val(Application.Version) < 12 Then
        szConnect = "Provider=Microsoft.Jet.OLEDB.4.0;" & _
                    "Data Source=" & SourceFile & ";" & _
                    "Extended Properties=""Excel 8.0;HDR=Yes"";"
    Else
        szConnect = "Provider=Microsoft.ACE.OLEDB.12.0;" & _
                    "Data Source=" & SourceFile & ";" & _
                    "Extended Properties=""Excel 12.0;HDR=Yes"";"
    End If
    End If

   If SourceSheet = "" Then
    ' workbook level name
    szSQL = "SELECT * FROM " & SourceRange$ & ";"
Else
    ' worksheet level name or range
    szSQL = "SELECT * FROM [" & SourceSheet$ & "$" & SourceRange$ & "];"
End If

On Error GoTo SomethingWrong

Set rsCon = CreateObject("ADODB.Connection")
Set rsData = CreateObject("ADODB.Recordset")

rsCon.Open szConnect
rsData.Open szSQL, rsCon, 0, 1, 1

' Check to make sure we received data and copy the data
If Not rsData.EOF Then

    If Header = False Then
        TargetRange.Cells(1, 1).CopyFromRecordset rsData
    Else
        'Add the header cell in each column if the last argument is True
        If UseHeaderRow Then
            For lCount = 0 To rsData.Fields.Count - 1
                TargetRange.Cells(1, 1 + lCount).Value = _
                rsData.Fields(lCount).Name
            Next lCount
            TargetRange.Cells(2, 1).CopyFromRecordset rsData
        Else
            TargetRange.Cells(1, 1).CopyFromRecordset rsData
        End If
    End If

Else
    MsgBox "No records returned from : " & SourceFile, vbCritical
End If

' Clean up our Recordset object.
rsData.Close
Set rsData = Nothing
rsCon.Close
Set rsCon = Nothing
Exit Sub

SomethingWrong:
MsgBox "The file name, Sheet name or Range is invalid of : " & SourceFile, _
       vbExclamation, "Error"
On Error GoTo 0

End Sub

Let me know if you need me to explain anything in more detail.


Solution

  • Something like this -skipping the whole ADO thing:

    Sub GetData_Example4()
    
        Dim SaveDriveDir As String, MyPath As String
        Dim FName As Variant, wb As Workbook, shtDest As Worksheet
    
        SaveDriveDir = CurDir
        MyPath = Application.DefaultFilePath    'or use "C:\Data"
        ChDrive MyPath
        ChDir MyPath
        FName = Application.GetOpenFilename(filefilter:="Excel Files, *.xl*")
    
        If FName = False Then
            'do nothing
        Else
            Application.ScreenUpdating = False
            Set shtDest = ThisWorkbook.Sheets("Sheet1")
            With Workbooks.Open(FName, ReadOnly:=True)
                .Sheets("Sheet1").Range("D1:D10000").Copy shtDest.Range("A1")
                .Sheets("Sheet1").Range("H1:H10000").Copy shtDest.Range("B1")
                .Sheets("Sheet1").Range("Q1:Q10000").Copy shtDest.Range("C1")
                .Sheets("Sheet1").Range("R1:R10000").Copy shtDest.Range("D1")
                .Close False '<< fixed
            End With
            Application.ScreenUpdating = True
        End If
    
        ChDrive SaveDriveDir
        ChDir SaveDriveDir
    End Sub