Import Sheet

[motabrasil]

Hey fellows,

I have the code described that basically capture a sheet from another workbook and paste in the active workbook.
However, the problem I'm facing is, for each column the code only import the majority data (between TEXT or NUMBER) for each column.
For example, if in the column "C", we have 70% of the contents are NUMBERS and the others 30% are TEXT, the code will import only the 70% of NUMBERS. Not even the column header is imported.
Anyone know how to fix that?

Thank you!!!

Private Sub OptBOMYes_Click()<?xml:namespace prefix = o ns = "urn:schemas-microsoft-comfficeffice" /><o></o>
Dim SaveDriveDir As String, MyPath As String<o></o>
Dim FName As Variant<o></o>
Dim J As Long, X As Long, Y As Long, K As Long<o></o>
Dim LastColumn As Long, LastRow As Long<o></o>
Dim wsBOM As Worksheet<o></o>
<o></o>
SaveDriveDir = CurDir<o></o>
MyPath = Application.DefaultFilePath<o></o>
ChDrive MyPath<o></o>
ChDir MyPath<o></o>
FName = Application.GetOpenFilename(filefilter:="Excel Files, *.xlsx*")<o></o>
<o></o>
If FName = False Then<o></o>
'do nothing<o></o>
Else<o></o>
GetData FName, "CBOM", "A2:BB1000", Sheets("BOM").Range("B2"), False, False<o></o>
End If<o></o>
<o></o>
ChDrive SaveDriveDir<o></o>
ChDir SaveDriveDir<o></o>
<o></o>
MsgBox "Done!!!"<o></o>
Unload Me<o></o>
End Sub

 

[Norie]

I'm pretty sure the problem isn't to do with this particular code but probably the GetData sub.

 

[motabrasil]

Is there any way to solve that issue?

Thanks

 

[Norie]

Hard to tell without either knowing what GetData is meant to do and/or seeing it's code.

 

[motabrasil]

Hi Norie

Basically, this code capture a sheet from another folder and paste in the current workbook, tab "BOM".Range("B2"). The problem is, as I explained previously, if I have in the same column, text and numbers, this macro will privilege what we have more, fulfilling with blanks the minority. The other issue I have is, this code only capture file with ".xlsx" extension. I need to turn it able to capture every excel files.

Could you help me?

Thank you once again

Private Sub CaptureSheet
Dim SaveDriveDir As String, MyPath As String<?xml:namespace prefix = o ns = "urn:schemas-microsoft-comfficeffice" /><o></o>
Dim FName As Variant<o></o>
Dim wsBOM As Worksheet<o></o>
<o></o>
SaveDriveDir = CurDir<o></o>
MyPath = Application.DefaultFilePath<o></o>
ChDrive MyPath<o></o>
ChDir MyPath<o></o>
FName = Application.GetOpenFilename(filefilter:="Excel Files, *.xlsx*")<o></o>
<o></o>
If FName = False Then<o></o>
'do nothing<o></o>
Else<o></o>
GetData FName, "CBOM", "A2:BB1000", Sheets("BOM").Range("B2"), False, False<o></o>
End If<o></o>
<o></o>
ChDrive SaveDriveDir<o></o>
ChDir SaveDriveDir<o></o>
<o></o>
MsgBox "Done!!!"<o></o>
Unload Me<o></o>
End Sub <!-- / message -->

 

[Norie]

We might be able to help if we could see the code for the GetData sub/function.

 

[motabrasil]

See below:


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