Excel VBA-Kopierwert auf neu

Ich bin ganz neu in VBA und Makros. Ich bin ziemlich anständig gestolpert, aber ich bin auf dieses Problem gestoßen, und ich bin nicht sicher, wie ich den Code optimieren soll.

Der Benutzer muss in der Lage sein, einen Wert (eine Zahl) einzugeben, um das gesamte Arbeitsblatt zu durchsuchen. Ist dieser gefunden, kopieren Sie ihn und fügen ihn in die nächste leere Zelle in Spalte B auf einem anderen Blatt im selben Arbeitsblatt ein.

Es wird immer weniger, wo ich es haben will.

Jede Hilfe wäre dankbar.

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

Hier ist der Aufruf von If 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

Update: Jetzt findet es den Wert und fügt ihn in die richtige Spalte ein, fügt aber statt nur einer Zelle 4 Zellen nach unten ein. Wenn die Daten nicht gefunden werden, wird trotzdem eingefügt, was auch immer sich in der Zwischenablage befindet.

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

Sie müssen davon Abstand nehmen, .SelectZellen, Zellbereiche und sogar Arbeitsblätter als Referenzierungsmethode zu verwenden. Jedes kann direkt auf seine eigene Weise referenziert werden. Weitere Informationen finden Sie unter Vermeiden der Verwendung von Select in Excel VBA-Makros von dieser anderen Site.

Hier ist ein Code, der direkte Verweise verwendet, um die von Ihnen festgelegten Ziele zu erreichen.

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

Ich habe VBAs verwendet Application.Countif, um alle ausgefüllten Zellen in jedem Arbeitsblatt gleichzeitig .CurrentRegionzu betrachten. Das Arbeitsblatt .Cells(1, 1).CurrentRegionist die ununterbrochene Dateninsel, die bei A1 beginnt und nach rechts und unten fortgesetzt wird, bis eine vollständig leere Zeile oder Spalte gefunden wird. Sie können dies demonstrieren, indem Sie A1 auswählen und auf Ctrl+ tippen A.