VBA: Importing data from one worksheet to another returns "TRUE"

[rcastilho91]

Hey, guys.

I'm here because of an issue that's driven me nuts and I just can't seem to find a solution, although it's probably pretty simple. I can't find any similar issues, so here it goes.


To summarize, let's assume there is a report that comes in regularly and has 100 columns. I need only 5 of those. As to simplify the process, I've created a routine that goes pretty much like this:

1. In one Excel sheet, I have the titles of the headers I want to copy. The code reads the content in the header, searches for it in the source Excel, copies the entire content, goes back to the destination Excel and pastes it.

It works beautifully, except for one detail: it messes up the first line, every single time. In a very simple example, let's say this is the case:

Before importing:

Source:



Name
Number


John
20


Cena
16



How it's imported to the destination table:




Name
Number


TRUE
TRUE


Cena
16



Admit that, of course, there are dozens and dozens of rows. But the contents of the first one is always replaced by TRUE in every cell, and the rest is copied properly. With that said, the code can be found below:



Sub importdata()

Dim wbBook As ThisWorkbook
Dim wbImportMe As Workbook
Dim HeaderContent
Dim Rng As Range
Dim SrcRng As Range

'Declaring which are the worksheets
Set wbImportMe = Workbooks.Open("C:\Users\RCO1\Desktop\Teste VBA\2. Conceptual Testing\1. Excel to Excel Importing\Importme.xlsb")
Set wbBook = ThisWorkbook

'Establishing starting point in destination sheet
Set Rng = wbBook.Sheets("Sheet1").Range("A1")

'Establishing variable to retain text to be searched
HeaderContent = Rng.Value


'Procedure to search, copy and paste values while there are cells with content
Do While HeaderContent <> ""

'Activates source sheet
wbImportMe.Activate
wbImportMe.Sheets("ps (98)").Activate

'Seeks content stored in the variable
Cells.Find(What:=HeaderContent, After:=ActiveCell, LookIn:=xlFormulas, LookAt _
:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:= _
False, SearchFormat:=False).Activate

'Skips to the next row after finding the header
Set SrcRng = ActiveCell.Offset(1, 0)
'Selects and copies the entire column
Range(Selection, Selection.End(xlDown)).Select
Selection.Copy

'Activates destination sheet
wbBook.Activate
wbBook.Sheets("Sheet1").Activate

'Selects current position where the header is, goes down a row and pastes the content
Rng.Select
Set Rng = ActiveCell.Offset(1, 0)
ActiveSheet.Paste

'Finds content back in destination sheet
Rng = Cells.Find(What:=HeaderContent, After:=ActiveCell, LookIn:=xlFormulas, LookAt _
:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:= _
False, SearchFormat:=False).Activate

'Selects the next header in X axis, activates it and redefines the variable to it
Set Rng = ActiveCell.Offset(0, 1)
Rng.Select
HeaderContent = Rng.Value

'Loops until empty header is found
Loop

'Closes source table
wbImportMe.Close

End Sub


If you guys can see my mistake, I'd highly appreciate if you could point it out.

Thanks a lot!

[SamT]

I don't really know. I didn't see anything that I thought could cause that.

For your edification, I rewrote that really good Macro to get rid of the Activates and Selects. In order to get rid of all of them, I had to change the WorkSheet.Paste to a Range.PasteSpecial. That transformed the "Macro" into a "Procedure."

Avoid using "Activate" and "select" when ever possible.

Here is that code
Sub importdata()

Dim wbBook As ThisWorkbook
Dim wbImportMe As Workbook
Dim HeaderContent As String '<------------
Dim Rng As Range
Dim SrcRng As Range

'Declaring which are the worksheets
Set wbImportMe = Workbooks.Open("C:\Users\RCO1\Desktop\Teste VBA\2. Conceptual Testing\1. Excel to Excel Importing\Importme.xlsb")
Set wbBook = ThisWorkbook

'Establishing starting point in destination sheet
Set Rng = wbBook.Sheets("Sheet1").Range("A1")

'Establishing variable to retain text to be searched
HeaderContent = Rng

'Procedure to search, copy and paste values while there are cells with content
Do While HeaderContent <> "" 'Loops until empty header is found

'Seeks content stored in the variable
Set SrcRng = Cells.Find(What:=HeaderContent).Offset(1, 0)
Range(SrcRng, SrcRng.End(xlDown)).Copy

'Activates destination sheet
Rng.Offset(1, 0).PasteSpecial
Set Rng = Rng.Offset(0, 1)
HeaderContent = Rng.Value
Loop

'Closes source table
wbImportMe.Close

End Sub

This is the way I would accomplish the same thing. NB: Option Base 1 is required to start the Array index at 1

Compiles, but not tested
Option Explicit
Option Base 1

Sub VBAX_SamT_importdata()

Dim SrcBk As Workbook
Dim ImportHeaders As Range
Dim myHeaders As Variant
Dim DestSht As Worksheet
Dim i As Long

Set DestSht = ThisWorkbook.Sheets("Sheet1")
Set SrcBk = Workbooks.Open("C:\Users\RCO1\Desktop\Teste VBA\2. Conceptual Testing\1. Excel to Excel Importing\Importme.xlsb")
Set ImportHeaders = SrcBk.Sheets("ps (98)").Rows(1)
myHeaders = Array("Name", "Number", "header3", "Header4", "Header5") 'Edit to the actual headers you need

For i = 1 To 5
ImportHeaders.Find(myHeaders(i)).EntireColumn.Copy DestSht.Cells(i)
Next i

SrcBk.Close
End Sub

As you can see, other than setting up the variables and opening the Import book, there are only three lines of code that do all the work.

[mancubus]

@SamT
how about ADO?



Sub vbax_54967_Import_Cols_From_Another_Workbook()
'requires a reference to Microsoft ActiveX Data Objects X.X Library

Dim cnn As New ADODB.Connection, rst As New ADODB.Recordset
Dim SourceFile As String, SourceSheet As String, FieldNames As String

SourceFile = "C:\Users\RCO1\Desktop\Teste VBA\2. Conceptual Testing\1. Excel to Excel Importing\Importme.xlsb"
SourceSheet = "ps (98)"
cnn.Open "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & SourceFile & ";Extended Properties=""Excel 12.0;HDR=Yes"";"

With ThisWorkbook.Worksheets("Sheet1")
.UsedRange.Offset(1).Clear
FieldNames = Join(Application.Transpose(Application.Transpose(.UsedRange.Value)), ", ")
rst.Open "SELECT " & FieldNames & " FROM [" & SourceSheet & "$];", cnn, adOpenStatic, adLockReadOnly
.Cells(2, 1).CopyFromRecordset rst
End With

rst.Close
cnn.Close

End Sub

[SamT]

That looks really fast.

[rcastilho91]

You guys kick ass, man. Thanks immensely.

I used SamT's first code. I appreciate your suggestion too, Mancubus, but that looks slightly over my head although seemingly simple hahaha

Thanks again!