Filling and importing data with VBA in excel, help in code?

Question

Hello, the situation that I am trying to automate in excel, through VBA is the following: I have two spreadsheets (different excel files), where the two have the same header (with information like ID, Name, Description...), but with columns in different order (in sheet 1, Name is column C, and in sheet 2, Name is column F, for example). In one of these worksheets, the content is filled and in the other there is only the header, so I created a VBA button in the worksheet where there is only the header, so that it looks for the information corresponding to each column of the header and imports the data (copy and paste)automatically. The code I created is the following, and this giving error, referring to object :

Sub Botão4_Clique()

    Dim contador, col As Integer
    Dim valor, PastaAtual, NomeDoArquivo, NomeCompletoDoArquivo As String
    Dim Busca As Range

    contador = 0
    col = 1

    ThisWorkbook.Worksheets("Plan1").Activate


    Do While Cells(1, col).Value <> ""

        Cells(1, col).Select
        valor = Cells(1, col).Value


        PastaAtual = Application.ActiveWorkbook.Path
        NomeDoArquivo = "teste.xlsx"
        NomeCompletoDoArquivo = PastaAtual + "\" + NomeDoArquivo
        Workbooks.Open (NomeCompletoDoArquivo)

        Set Busca = Cells.Find(What:=valor, After:=ActiveCell, LookIn:=xlFormulas, LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False, SearchFormat:=False).Activate

        ThisWorkbook.Worksheets("Plan1").Activate
        Cells(1, col).Activate
        Set tbl = ActiveCell
        tbl.Offset(1, 0).Resize(tbl.Rows.Count - 1, tbl.Columns.Count).Select
        ActiveCell.Offset(rowOffset:=1, columnOffset:=0).Select
        Selection.Copy
        Workbooks(NomeCompletoDoArquivo).Select
        ActiveSheet.Paste
        Application.CutCopyMode = False


        contador = contador + 1
       col = col + 1
    Loop


MsgBox contador


End Sub

What could be wrong? Thank you

Answer 1

The Excerpt seems incorrect:

 Set Busca = Cells.Find(What:=valor, After:=ActiveCell, LookIn:=xlFormulas, LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False, SearchFormat:=False).Activate

In accordance with https://msdn.microsoft.com/en-us/library/office/ff837085.aspx Range.Activate is a method and as such he does not expect to return a value Range for Search but a Variant

In addition there are other mistakes. I propose the following:

Sub Importa()

Dim contador, col As Integer
Dim valor, PastaAtual, NomeDoArquivo, NomeCompletoDoArquivo As String
Dim Busca As Range
Dim RangeFrom As Range
Dim RangeTo As Range
Dim Busca_col As Integer
Dim WorkBookNovo As Workbook

contador = 0
col = 1


ThisWorkbook.Worksheets("Plan1").Activate
PastaAtual = Application.ActiveWorkbook.Path
NomeDoArquivo = "Pasta2.xlsx"
NomeCompletoDoArquivo = PastaAtual + "\" + NomeDoArquivo
Set WorkBookNovo = Workbooks.Open(NomeCompletoDoArquivo)
ThisWorkbook.Worksheets("Plan1").Activate

Do While Cells(1, col).Value <> ""

    Cells(1, col).Select
    valor = Cells(1, col).Value

    Columns(col).Select
    numRows = Selection.Rows.Count
    Selection.Resize(numRows - 1).Select
    Selection.Offset(1, 0).Select
    Set RangeFrom = Selection

    WorkBookNovo.Activate
    Set Busca = WorkBookNovo.Application.Cells.Find(What:=valor, After:=ActiveCell, LookIn:=xlFormulas, LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False, SearchFormat:=False)
    Busca.Activate
    Busca_col = Busca.Column
    WorkBookNovo.ActiveSheet.Columns(Busca_col).Select
    numRows = Selection.Rows.Count
    Selection.Resize(numRows - 2).Select
    Selection.Offset(2, 0).Select
    Selection.Value = RangeFrom.Value
    ThisWorkbook.Worksheets("Plan1").Activate

    contador = contador + 1
   col = col + 1
Loop

MsgBox contador

End Sub

If you want to improve the demepenho it would be nice to identify the last line to delimit a smaller range instead of ActiveSheet.Columns(Busca_col).Select