Excel VBA скопировать значение в новый

Question

Я новичок в VBA и макросах. Я довольно прилично спотыкался, но столкнулся с этой проблемой и не уверен, как настроить код.

Мне нужно, чтобы у пользователя была возможность ввести значение (число) для поиска по всему рабочему листу, а затем, когда он найден, скопировать и вставить в следующую пустую ячейку в столбце B на другом листе того же рабочего листа.

Все меньше и меньше становится там, где я хочу.

Любая помощь будет оценена.

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

Вот вызов, если ActiveCell.Значение = 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

Обновление: теперь он найдет значение и вставит его в соответствующий столбец, но вставит 4 ячейки вместо одной, а когда данные не найдены, он все равно вставит все, что находится в буфере обмена.

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

Answer 1

Вы должны уйти от использования .Select в качестве метода ссылки на ячейки, диапазоны ячеек и даже рабочие листы. На каждую ссылку можно ссылаться по-своему. См. Как не использовать макросы Select в Excel VBA с этого другого сайта.

Вот некоторый код, который использует прямые ссылки при достижении поставленных целей.

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

Я использовал приложение VBA .Нажмите, чтобы посмотреть на все заполненные ячейки в каждом рабочем листе .CurrentRegion сразу. Рабочий лист .Клетки (1, 1).CurrentRegion - это непрерывный островок данных, начинающийся с A1 и продолжающийся как вправо, так и вниз, пока не встретит полностью пустую строку или столбец. Вы можете продемонстрировать это, выбрав A1 и нажав Ctrl+A.