Valor de cópia do VBA do Excel para novo

Sou novato em VBA e macros. Eu andei tropeçando de maneira decente, mas me deparei com esse problema e não sei como ajustar o código.

Eu preciso que o usuário seja capaz de inserir um valor (número) para pesquisar a planilha inteira e, uma vez encontrada, copie e cole na próxima célula vazia na coluna B em outra planilha na mesma planilha.

Está ficando cada vez menos onde eu quero.

Qualquer ajuda seria apreciada.

Sub Reference_Lookup_Paste()
' Written by Barrie Davidson
Dim datatoFind
Dim sheetCount As Integer
Dim counter As Integer
Dim currentSheet As Integer

Application.ScreenUpdating = False

On Error Resume Next
currentSheet = ActiveSheet.Index
datatoFind = InputBox("Please enter the Reference Number.")
If datatoFind = "" Then Exit Sub
sheetCount = ActiveWorkbook.Sheets.count
If IsError(CDbl(datatoFind)) = False Then datatoFind = CDbl(datatoFind)
For counter = 1 To sheetCount
Sheets(counter).Activate
Cells.Find(What:=datatoFind, After:=ActiveCell, LookIn:=xlFormulas, LookAt _
:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:= _
False).Activate
If ActiveCell.Value = datatoFind Then Call Reference_Move
On Error Resume Next

Next counter
If ActiveCell.Value <> datatoFind Then
MsgBox ("Value not found")
Sheets(currentSheet).Activate
End If
End Sub

Sub Reference_Move()
Selection.Copy
Sheets("Service-Warranty").Select

Dim r1 As Range, r2 As Range
Set r1 = Intersect(Range("B:B"), Cells.SpecialCells(xlCellTypeBlanks))
Set r2 = Cells(Rows.count, "B").End(xlUp).Offset(1, 0)
If r1 Is Nothing Then
    r2.Select
Else
    r1(1).Select
End If
ActiveSheet.Paste
End Sub

Aqui está a chamada se ActiveCell.Value = datatoFind

Sub Reference_Move()
Selection.Copy
Sheets("Service-Warranty").Select

Dim r1 As Range, r2 As Range
Set r1 = Intersect(Range("B:B"), Cells.SpecialCells(xlCellTypeBlanks))
Set r2 = Cells(Rows.count, "B").End(xlUp).Offset(1, 0)
If r1 Is Nothing Then
    r2.Select
Else
    r1(1).Select
End If
ActiveSheet.Paste
End Sub

Atualização: agora ele encontrará o valor e colará na coluna apropriada, mas cola 4 células em vez de apenas uma e, quando os dados não são encontrados, ainda cola o que estiver na área de transferência.

Sub Reference_Lookup_Paste()
' Written by Barrie Davidson
Dim datatoFind
Dim sheetCount As Integer
Dim counter As Integer
Dim currentSheet As Integer

Application.ScreenUpdating = False

On Error Resume Next
currentSheet = ActiveSheet.Index
datatoFind = InputBox("Please enter the Reference Number.")
If datatoFind = "" Then Exit Sub
sheetCount = ActiveWorkbook.Sheets.count
If IsError(CDbl(datatoFind)) = False Then datatoFind = CDbl(datatoFind)
For counter = 1 To sheetCount
Sheets(counter).Activate
Cells.Find(What:=datatoFind, After:=ActiveCell, LookIn:=xlFormulas, LookAt _
:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:= _
False).Activate
If ActiveCell.Value = datatoFind Then Selection.Copy

Sheets("Service-Warranty").Select

Range("B1").End(xlDown).Offset(1, 0).Select
ActiveSheet.Paste

Next counter
If ActiveCell.Value <> datatoFind Then
MsgBox ("Value not found")
Sheets(currentSheet).Activate
End If
End Sub

Você precisa evitar o uso .Selectcomo método de referência a células, intervalos de células e até planilhas. Cada um pode ser diretamente referenciado à sua maneira. Consulte Como evitar o uso de macros Select no Excel VBA desse outro site.

Aqui está um código que usa referência direta ao atingir os objetivos que você definiu.

Sub Reference_Lookup_Paste()
    Dim sMsg As String, datatoFind As Variant
    Dim s As Long, rw As Long, cl As Long

    Application.ScreenUpdating = False

    datatoFind = InputBox("Please enter the Reference Number.")
    If datatoFind = "" Then Exit Sub
    If IsNumeric(datatoFind) Then datatoFind = CDbl(datatoFind)
    sMsg = datatoFind & " found on:" & Chr(10)
    For s = 1 To ActiveWorkbook.Sheets.Count
        If Not Sheets(s).Name = "Service-Warranty" Then 'assumed that you want to skip this one
            With Sheets(s).Cells(1, 1).CurrentRegion
                If CBool(Application.CountIf(.Cells, datatoFind)) Then
                    sMsg = sMsg & .Parent.Name & Chr(10)
                    Sheets("Service-Warranty").Cells(Rows.Count, 2).End(xlUp).Offset(1, 0) = datatoFind
                    Exit For
                End If
            End With
        End If
    Next s

    If Len(sMsg) > (InStr(1, sMsg, datatoFind & " found on:" & Chr(10), vbTextCompare) + 1) Then
        MsgBox sMsg
    Else
        MsgBox datatoFind & "Value not found."
    End If

    Application.ScreenUpdating = True
End Sub

Eu usei o VBA Application.Countifpara examinar todas as células preenchidas em cada planilha de .CurrentRegionuma só vez. A planilha .Cells(1, 1).CurrentRegioné a ilha ininterrupta de dados, iniciando em A1 e continuando à direita e para baixo até encontrar uma linha ou coluna completamente em branco. Você pode demonstrar isso selecionando A1 e tocando em Ctrl+ A.