timawfi
10-08-2009, 08:25 AM
Hello,
I'm using the following code to import data from a sheet in a closed workbook to a sheet in an open workbook:
Option Explicit
Sub GetData_ClosedWorkBook()
Dim sh As Worksheet
Dim rDest As Range
Dim SaveDriveDir As String
Dim sPath As String
Dim FName As Variant
Dim N As Long
Dim lNum As Long
SaveDriveDir = CurDir
sPath = Application.DefaultFilePath 'or use "C:\Data"
ChDrive sPath
ChDir sPath
FName = Application.GetOpenFilename(filefilter:="Excel Files,*.xls", _
MultiSelect:=False)
If IsArray(FName) Then
' Sort the Array
FName = Array_Sort(FName)
Application.ScreenUpdating = False
'Add worksheet to the Activeworkbook and use the Date/Time as name
'You can change this to suit
Set sh = ActiveWorkbook.Sheets("Materials")
'Loop through all files you select in the GetOpenFilename dialog
For N = LBound(FName) To UBound(FName)
'create the destination cell address
Set rDest = Range("Materials!A6")
GetData FName(N), "Materials", "B22:H1521", rDest, False, False
Set rDest = Range("Materials!A1508")
GetData FName(N), "Materials", "J22:P221", rDest, False, False
Set rDest = Range("Materials!A1709")
GetData FName(N), "Materials", "R22:X221", rDest, False, False
Next
End If
ChDrive SaveDriveDir
ChDir SaveDriveDir
Application.ScreenUpdating = True
End Sub
Option Explicit
Public Sub GetData(SourceFile As Variant, SourceSheet As String, _
sourceRange As String, TargetRange As Range, Header As Boolean, UseHeaderRow As Boolean)
Dim rsData As ADODB.Recordset
Dim szConnect As String
Dim szSQL As String
Dim lCount As Long
If Header = False Then
' Create the connection string.
szConnect = "Provider=Microsoft.Jet.OLEDB.4.0;" & _
"Data Source=" & SourceFile & ";" & _
"Extended Properties=""Excel 8.0;HDR=No"";"
Else
' Create the connection string.
szConnect = "Provider=Microsoft.Jet.OLEDB.4.0;" & _
"Data Source=" & SourceFile & ";" & _
"Extended Properties=""Excel 8.0;HDR=Yes"";"
End If
szSQL = "SELECT * FROM [" & SourceSheet$ & "$" & sourceRange$ & "];"
On Error GoTo SomethingWrong
Set rsData = New ADODB.Recordset
rsData.Open szSQL, szConnect, adOpenForwardOnly, _
adLockReadOnly, adCmdText
'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
Exit Sub
SomethingWrong:
MsgBox "The file name, Sheet name or Range is invalid of : " & SourceFile, _
vbExclamation, "Error"
On Error GoTo 0
End Sub
Function LastRow(sh As Worksheet)
On Error Resume Next
LastRow = sh.Cells.Find(What:="*", _
After:=sh.Range("A1"), _
Lookat:=xlPart, _
LookIn:=xlFormulas, _
SearchOrder:=xlByRows, _
SearchDirection:=xlPrevious, _
MatchCase:=False).Row
On Error GoTo 0
End Function
Function Array_Sort(ArrayList As Variant) As Variant
Dim aCnt As Integer, bCnt As Integer
Dim tempStr As String
For aCnt = LBound(ArrayList) To UBound(ArrayList) - 1
For bCnt = aCnt + 1 To UBound(ArrayList)
If ArrayList(aCnt) > ArrayList(bCnt) Then
tempStr = ArrayList(bCnt)
ArrayList(bCnt) = ArrayList(aCnt)
ArrayList(aCnt) = tempStr
End If
Next bCnt
Next aCnt
Array_Sort = ArrayList
End Function
The problem i'm experiencing, is cells with non-numeric values (i.e., "R820D0") are imported, and cells with numeric values (i.e., "980") are not imported, leaving a blank cell in the destination sheet.
Does anyone have any idea why this is happening? Would really appreciate any help on this.
Thanks!
I'm using the following code to import data from a sheet in a closed workbook to a sheet in an open workbook:
Option Explicit
Sub GetData_ClosedWorkBook()
Dim sh As Worksheet
Dim rDest As Range
Dim SaveDriveDir As String
Dim sPath As String
Dim FName As Variant
Dim N As Long
Dim lNum As Long
SaveDriveDir = CurDir
sPath = Application.DefaultFilePath 'or use "C:\Data"
ChDrive sPath
ChDir sPath
FName = Application.GetOpenFilename(filefilter:="Excel Files,*.xls", _
MultiSelect:=False)
If IsArray(FName) Then
' Sort the Array
FName = Array_Sort(FName)
Application.ScreenUpdating = False
'Add worksheet to the Activeworkbook and use the Date/Time as name
'You can change this to suit
Set sh = ActiveWorkbook.Sheets("Materials")
'Loop through all files you select in the GetOpenFilename dialog
For N = LBound(FName) To UBound(FName)
'create the destination cell address
Set rDest = Range("Materials!A6")
GetData FName(N), "Materials", "B22:H1521", rDest, False, False
Set rDest = Range("Materials!A1508")
GetData FName(N), "Materials", "J22:P221", rDest, False, False
Set rDest = Range("Materials!A1709")
GetData FName(N), "Materials", "R22:X221", rDest, False, False
Next
End If
ChDrive SaveDriveDir
ChDir SaveDriveDir
Application.ScreenUpdating = True
End Sub
Option Explicit
Public Sub GetData(SourceFile As Variant, SourceSheet As String, _
sourceRange As String, TargetRange As Range, Header As Boolean, UseHeaderRow As Boolean)
Dim rsData As ADODB.Recordset
Dim szConnect As String
Dim szSQL As String
Dim lCount As Long
If Header = False Then
' Create the connection string.
szConnect = "Provider=Microsoft.Jet.OLEDB.4.0;" & _
"Data Source=" & SourceFile & ";" & _
"Extended Properties=""Excel 8.0;HDR=No"";"
Else
' Create the connection string.
szConnect = "Provider=Microsoft.Jet.OLEDB.4.0;" & _
"Data Source=" & SourceFile & ";" & _
"Extended Properties=""Excel 8.0;HDR=Yes"";"
End If
szSQL = "SELECT * FROM [" & SourceSheet$ & "$" & sourceRange$ & "];"
On Error GoTo SomethingWrong
Set rsData = New ADODB.Recordset
rsData.Open szSQL, szConnect, adOpenForwardOnly, _
adLockReadOnly, adCmdText
'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
Exit Sub
SomethingWrong:
MsgBox "The file name, Sheet name or Range is invalid of : " & SourceFile, _
vbExclamation, "Error"
On Error GoTo 0
End Sub
Function LastRow(sh As Worksheet)
On Error Resume Next
LastRow = sh.Cells.Find(What:="*", _
After:=sh.Range("A1"), _
Lookat:=xlPart, _
LookIn:=xlFormulas, _
SearchOrder:=xlByRows, _
SearchDirection:=xlPrevious, _
MatchCase:=False).Row
On Error GoTo 0
End Function
Function Array_Sort(ArrayList As Variant) As Variant
Dim aCnt As Integer, bCnt As Integer
Dim tempStr As String
For aCnt = LBound(ArrayList) To UBound(ArrayList) - 1
For bCnt = aCnt + 1 To UBound(ArrayList)
If ArrayList(aCnt) > ArrayList(bCnt) Then
tempStr = ArrayList(bCnt)
ArrayList(bCnt) = ArrayList(aCnt)
ArrayList(aCnt) = tempStr
End If
Next bCnt
Next aCnt
Array_Sort = ArrayList
End Function
The problem i'm experiencing, is cells with non-numeric values (i.e., "R820D0") are imported, and cells with numeric values (i.e., "980") are not imported, leaving a blank cell in the destination sheet.
Does anyone have any idea why this is happening? Would really appreciate any help on this.
Thanks!