Macro to get data not getting numbers

[nslemmons]

Hi I poseted earlier this morning about a problem with a group of functions in Excel VBA. Geoff helped me out with that but I have discovered another problem. The macro is used to get data from an Excel workbook I select from a popup. It gets all of the information except for numbers. I'm not sure what part of the code is missing it. I will post the whole thing.

ub GetData_Example2()
    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, *.xls")

 

    If FName = False Then
        'do nothing
    Else
        GetData FName, "Carrier Profile", "B8:B194", ActiveCell, False
    End If

 

    ChDrive SaveDriveDir
    ChDir SaveDriveDir
End Sub

Public Sub GetData(SourceFile As Variant, SourceSheet As String, _
                   sourceRange As String, TargetRange As Range, HeaderRow As Boolean)

    ' Changed on 20-Oct-2005
    Dim rsData As ADODB.Recordset
    Dim szConnect As String
    Dim szSQL As String
    Dim lCount As Long

 

    If Range(sourceRange).Rows.Count = 1 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 Range(sourceRange).Rows.Count = 1 Then
            TargetRange.Cells(1, 1).CopyFromRecordset rsData
        Else
            'Add the header cell in each column if the last argument is True
            If HeaderRow 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
Public Sub DeleteBlankRows()

Dim R As Long
Dim C As Range
Dim Rng As Range

On Error GoTo EndMacro
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual

If Selection.Rows.Count > 1 Then
    Set Rng = Selection
Else
    Set Rng = ActiveSheet.UsedRange.Rows
End If
For R = Rng.Rows.Count To 1 Step -1
    If Application.WorksheetFunction.CountA(Rng.Rows(R).EntireRow) = 0 Then
        Rng.Rows(R).EntireRow.Delete
    End If
Next R

EndMacro:

Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic

End Sub

Any help is appreciated.

Thanks,
Nate

 

[AnotherHiggins]

Please post your question in forum707, the VBA Visual Basic for Applications (Microsoft) Forum.

[tt]_____
[blue]-John[/blue][/tt]
[tab][red]The plural of anecdote is not data[/red]

Help us help you. Please read FAQ181-2886 before posting.

 

[nslemmons]

Thanks John!