Excel Macro not getting numbers from workbooks

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

Sub 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

 

[xlbo]

Likelihood is that the issue lies in the ADO SQL command. When executing a query using ADO, the 1st few rows of the prospective table to be queried are scanned to set data types for each field. If the 1st few rows are empty or contain text, the dataset will be set for text for that field. Any numbers further down will not be imported.

1st thing to look at is one of the source workbooks - see if my assumption is actually correct. If it is, you will need to either look at ways of making sure the 1st row of data has entries / correct data types or alternatively look at ADO properties to see if you can change something there. I tend to use ODBC myself so am not too familiar with ADO but as a last resort, you could use an ODBC querytable instead - this would mean some fairly major changes to the code however....

Rgds, Geoff

We could learn a lot from crayons. Some are sharp, some are pretty and some are dull. Some have weird names and all are different colours but they all live in the same box.

Please read FAQ222-2244 before you ask a question

 

[nslemmons]

Thanks again Geoff. The first several fields are in fact text. So ADO doesn't import information verbatim? Is there a way to just copy the information and paste it into another sheet?

Thanks,
Nate

 

[xlbo]

AFAIK, ADO sets data types for each field and if subsequent data is not of the right type, it is not included. This also happens when doing imports into MSAccess.

As I mentioned, I don't know a lot about ADO so there may be a switch that corrects this behaviour but I couldn't say for sure. If not, is there any way you can get rid of the text data ? otherwise we may have to look at using a different querying method which would require quite a bit of re-writing

Rgds, Geoff

We could learn a lot from crayons. Some are sharp, some are pretty and some are dull. Some have weird names and all are different colours but they all live in the same box.

Please read FAQ222-2244 before you ask a question

 

[SkipVought]

I would CHANGE the data in the column to STRING by including the ' prefix on all numeric values

sub Convert2String(ws as worksheet, iCol as Integer}
   dim r as range
   for each r in ws.range(ws.cells(1,icol),ws.cells(ws.usedrange.rows.count+ws.usedrange.row-1,icol))
      with r
        if isnumeric(.value) then .value = "'" & .value 
      end with 
   next
end sub

Skip,

_{[red]Be Advised![/red] A chicken, who would drag a wagon across the road for 2 cents, is…
POULTRY in motion to PULLET for a PALTRY amount!}

 

[nslemmons]

Thanks Skip and Geoff. Skip, I'm not sure where to include this code. Can you point me in the right direction?

Thanks,
Nate

 

[SkipVought]

Paste into a module.

Cll it like this...

Sub FixCol()
   Convert2String(Activesheet, 1}
End Sub

if your column is A.

Run FixCol

Skip,

_{[red]Be Advised![/red] A chicken, who would drag a wagon across the road for 2 cents, is…
POULTRY in motion to PULLET for a PALTRY amount!}

 

[SkipVought]

Sorry...

Sub FixCol()
   Convert2String Activesheet, 1
End Sub

Skip,

_{[red]Be Advised![/red] A chicken, who would drag a wagon across the road for 2 cents, is…
POULTRY in motion to PULLET for a PALTRY amount!}