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.
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