☰

Excel VBA 将值复制到新的

tag-icon • tag-icon microsoft-excel vba
Excel VBA 将值复制到新的

我对 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.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

更新：现在它会找到值并粘贴到正确的列中，但它会粘贴 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

答案1

您必须停止使用.Select作为引用单元格、单元格区域甚至工作表的方法。每个方法都可以以自己的方式直接引用。请参阅如何避免在 Excel VBA 宏中使用 Select来自另一个网站。

这里有一些使用直接引用来实现您设定的目标的代码。

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一次Application.Countif查看每个工作表中所有已填充的单元格.CurrentRegion。工作表是从 A1 开始的连续数据岛，一直向右向下直到遇到完全空白的行或列。您可以通过选择 A1 并点击+.Cells(1, 1).CurrentRegion来演示这一点。CtrlA

相关内容