搜索包含文本的单元格并在下一个空白单元格中粘贴值

Posted 2023-02-25

【中文标题】搜索包含文本的单元格并在下一个空白单元格中粘贴值

【英文标题】：Search for cell that contains text and paste value in next blank cell

【发布时间】：2021-08-14 14:16:54

【问题描述】：

我是 VBA 新手，有点挣扎。我需要在工作表 2 上的 Q 列中搜索包含“text”的单元格，然后将单元格中的数据复制到右侧，然后将此值粘贴到工作表 B 列的下一个空白单元格中.我一直在尝试使用 IF THEN 代码执行此操作，但不断出现错误。看起来很简单，但很苦恼，有人可以建议吗？ 我需要在第 4 周之后发布结果，当使用 .end(XLup) 时，代码运行但在 46 下发布结果。当切换到 XLdown 从顶部运行时出现错误。

 Sub question68784119()

Const SED As String = "tokyo" 'the text you're searching for"
Dim aCell As Range, wsPull As Worksheet, theCellValue As Variant, wsPaste As Worksheet

    Set wsPull = ThisWorkbook.Sheets("flavors_of_cacao")
    Set wsPaste = ThisWorkbook.Sheets("Sheet1")
    
    For Each aCell In Intersect(wsPull.UsedRange, wsPull.Range("F:G")).Cells
    
        theCellValue = aCell.Value2
        
        If InStr(1, theCellValue, SED, vbTextCompare) > 0 Then
        
            theCellValue = aCell.Offset(0, 1).Value
            wsPaste.Cells(Rows.Count, 5).End(xlDown).Offset(1, 0).Value = theCellValue
        
        End If
        
    Next aCell
    
MsgBox "Done!"

End Sub

【问题讨论】：

建议共享代码，包括到目前为止的错误。 （共享代码，意味着您使用edit 来改进您的问题，并在您的问题中复制/粘贴文本，没有图像）

当一个简单的 VLookup 公式可以完成您所描述的事情时，为什么还要使用 VBA？

1. 我建议使用.Find 来搜索文本。请参阅.Find & .FindNext 中的第 4 节。 2. 要将数据粘贴到下一个空白单元格中，请找到最后一行，如 HERE 所示。试一试，如果您仍然卡住，只需发布​​您尝试过的代码和错误消息（如果有），我们将从那里获取。

@Luuk 会继续前进，请给小费！

【参考方案1】：

VBA 查找

Range.End property Range.Find method （可选）可以将公式而不是值写入目标单元格（每个第 3 个解决方案）。

可读：

Sub VBALookupFind()
    
    Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
    
    Dim sws As Worksheet: Set sws = wb.Worksheets("Sheet2")
    Dim slRow As Long: slRow = sws.Cells(sws.Rows.Count, "Q").End(xlUp).Row
    If slRow < 2 Then Exit Sub ' no data
    
    Dim slrg As Range
    Set slrg = sws.Range(sws.Cells(2, "Q"), sws.Cells(slRow, "Q"))
    
    Dim slCell As Range
    Set slCell = slrg.Find("text", slrg.Cells(slrg.Cells.Count), _
        xlFormulas, xlWhole)
    If slCell Is Nothing Then Exit Sub ' no match
    
    Dim svCell As Range: Set svCell = slCell.EntireRow.Columns("R")
    
    Dim dws As Worksheet: Set dws = wb.Worksheets("Sheet1")
    Dim dRow As Long: dRow = dws.Cells(dws.Rows.Count, "B").End(xlUp).Row + 1
    Dim dCell As Range: Set dCell = dws.Cells(dRow, "B")
    
    dCell.Value = svCell.Value

End Sub

Sub VBALookupMatch()
    
    Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
    
    Dim sws As Worksheet: Set sws = wb.Worksheets("Sheet2")
    Dim slRow As Long: slRow = sws.Cells(sws.Rows.Count, "Q").End(xlUp).Row
    If slRow < 2 Then Exit Sub ' no data
    
    Dim slrg As Range
    Set slrg = sws.Range(sws.Cells(2, "Q"), sws.Cells(slRow, "Q"))
    
    Dim rIndex As Variant: rIndex = Application.Match("text", slrg, 0)
    If IsError(rIndex) Then Exit Sub ' no match
    
    Dim svrg As Range: Set svrg = slrg.EntireRow.Columns("R")
    
    Dim svCell As Range: Set svCell = svrg.Cells(rIndex)
    
    Dim dws As Worksheet: Set dws = wb.Worksheets("Sheet1")
    Dim dRow As Long: dRow = dws.Cells(dws.Rows.Count, "B").End(xlUp).Row + 1
    Dim dCell As Range: Set dCell = dws.Cells(dRow, "B")
    
    dCell.Value = svCell.Value
    
End Sub


Sub VBALookupFormula()
    
    Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
    
    Dim sws As Worksheet: Set sws = wb.Worksheets("Sheet2")
    Dim slRow As Long: slRow = sws.Cells(sws.Rows.Count, "Q").End(xlUp).Row
    If slRow < 2 Then Exit Sub ' no data
    
    Dim slrg As Range
    Set slrg = sws.Range(sws.Cells(2, "Q"), sws.Cells(slRow, "Q"))
    
    Dim svrg As Range: Set svrg = slrg.EntireRow.Columns("R")
        
    Dim dws As Worksheet: Set dws = wb.Worksheets("Sheet1")
    Dim dRow As Long: dRow = dws.Cells(dws.Rows.Count, "B").End(xlUp).Row + 1
    Dim dCell As Range: Set dCell = dws.Cells(dRow, "B")
    
    Dim dFormula As String
    dFormula = "=IFERROR(INDEX('" & "Sheet2" _
        & "'!" & svrg.Address(, 0) _
        & "," & "MATCH(""" & "text" _
        & """,'" & "Sheet2" _
        & "'!" & slrg.Address(, 0) _
        & ",0)),"""")"

    dCell.Formula = dFormula

End Sub

可维护，使用常量（与 Debug.Print 一起学习）

Sub VBALookupFindConstants()
    
    Const sName As String = "Sheet2" ' Source Worksheet Name
    Const sfRow As Long = 2 ' Source First Row
    Const slCol As String = "Q" ' Source Lookup Column
    Const slValue As String = "text" ' Source Lookup Value
    Const svCol As String = "R" ' Source Value Column
    
    Const dName As String = "Sheet1" ' Destination Worksheet Name
    Const dCol As String = "B" ' Destination Column
    
    Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
    
    Dim sws As Worksheet: Set sws = wb.Worksheets(sName)
    Dim slRow As Long: slRow = sws.Cells(sws.Rows.Count, slCol).End(xlUp).Row
    If slRow < sfRow Then Exit Sub ' no data
    
    Dim slrg As Range
    Set slrg = sws.Range(sws.Cells(sfRow, slCol), sws.Cells(slRow, slCol))
    Debug.Print "Source Lookup Range Address      " & slrg.Address(, 0)
    
    Dim slCell As Range
    Set slCell = slrg.Find(slValue, slrg.Cells(slrg.Cells.Count), _
        xlFormulas, xlWhole)
    If slCell Is Nothing Then Exit Sub ' no match
    Debug.Print "Source Lookup Cell Address       " & slCell.Address(0, 0)
    
    Dim svCell As Range: Set svCell = slCell.EntireRow.Columns(svCol)
    Debug.Print "Source Value Cell Address        " & svCell.Address(0, 0)
    
    Dim dws As Worksheet: Set dws = wb.Worksheets(dName)
    Dim dRow As Long: dRow = dws.Cells(dws.Rows.Count, dCol).End(xlUp).Row + 1
    Dim dCell As Range: Set dCell = dws.Cells(dRow, dCol)
    Debug.Print "Destination Cell Address         " & dCell.Address(0, 0)
    
    ' Value...
    dCell.Value = svCell.Value
    Debug.Print "Destination Cell Value           " & dCell.Value
    
End Sub

Sub VBALookupMatchConstants()
    
    Const sName As String = "Sheet2" ' Source Worksheet Name
    Const sfRow As Long = 2 ' Source First Row
    Const slCol As String = "Q" ' Source Lookup Column
    Const slValue As String = "text" ' Source Lookup Value
    Const svCol As String = "R" ' Source Value Column
    
    Const dName As String = "Sheet1" ' Destination Worksheet Name
    Const dCol As String = "B" ' Destination Column
    
    Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
    
    Dim sws As Worksheet: Set sws = wb.Worksheets(sName)
    Dim slRow As Long: slRow = sws.Cells(sws.Rows.Count, slCol).End(xlUp).Row
    If slRow < sfRow Then Exit Sub ' no data
    
    Dim slrg As Range
    Set slrg = sws.Range(sws.Cells(sfRow, slCol), sws.Cells(slRow, slCol))
    Debug.Print "Source Lookup Range Address      " & slrg.Address(, 0)
    
    Dim rIndex As Variant: rIndex = Application.Match(slValue, slrg, 0)
    If IsError(rIndex) Then Exit Sub ' no match
    Debug.Print "Match Index                      " & rIndex
    
    Dim svrg As Range: Set svrg = slrg.EntireRow.Columns(svCol)
    Debug.Print "Source Value Range Address       " & svrg.Address(, 0)
    
    Dim svCell As Range: Set svCell = svrg.Cells(rIndex)
    Debug.Print "Source Value Cell Address        " & svCell.Address(0, 0)
    
    Dim dws As Worksheet: Set dws = wb.Worksheets(dName)
    Dim dRow As Long: dRow = dws.Cells(dws.Rows.Count, dCol).End(xlUp).Row + 1
    Dim dCell As Range: Set dCell = dws.Cells(dRow, dCol)
    Debug.Print "Destination Cell Address         " & dCell.Address(0, 0)
    
    ' Value...
    dCell.Value = svCell.Value
    Debug.Print "Destination Cell Value           " & dCell.Value
    
End Sub


Sub VBALookupFormulaConstants()
    
    Const sName As String = "Sheet2" ' Source Worksheet Name
    Const sfRow As Long = 2 ' Source First Row
    Const slCol As String = "Q" ' Source Lookup Column
    Const slValue As String = "text" ' Source Lookup Value
    Const svCol As String = "R" ' Source Value Column
    
    Const dName As String = "Sheet1" ' Destination Worksheet Name
    Const dCol As String = "B" ' Destination Column
    
    Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
    
    Dim sws As Worksheet: Set sws = wb.Worksheets(sName)
    Dim slRow As Long: slRow = sws.Cells(sws.Rows.Count, slCol).End(xlUp).Row
    If slRow < sfRow Then Exit Sub ' no data
    
    Dim slrg As Range
    Set slrg = sws.Range(sws.Cells(sfRow, slCol), sws.Cells(slRow, slCol))
    Debug.Print "Source Lookup Range Address      " & slrg.Address(, 0)
    
    Dim svrg As Range: Set svrg = slrg.EntireRow.Columns(svCol)
    Debug.Print "Source Value Range Address       " & svrg.Address(, 0)
    
    Dim dws As Worksheet: Set dws = wb.Worksheets(dName)
    Dim dRow As Long: dRow = dws.Cells(dws.Rows.Count, dCol).End(xlUp).Row + 1
    Dim dCell As Range: Set dCell = dws.Cells(dRow, dCol)
    Debug.Print "Destination Cell Address         " & dCell.Address(0, 0)

    Dim dFormula As String
    dFormula = "=IFERROR(INDEX('" & sName _
        & "'!" & svrg.Address(, 0) _
        & "," & "MATCH(""" & slValue _
        & """,'" & sName _
        & "'!" & slrg.Address(, 0) _
        & ",0)),"""")"
    Debug.Print "Destination Cell Formula         " & dFormula
    
    dCell.Formula = dFormula
    Debug.Print "Destination Cell Value           " & dCell.Value

End Sub

【讨论】：

谁也反对这个答案？！？它有效且内容丰富！

【参考方案2】：

您应该发布您在问题中所做的任何尝试，但这会按照您指定的方式进行。

Sub question68784119()
Const tangoText As String = "text" 'the text you're searching for
Dim aCell As Range, wsPull As Worksheet, theCellValue As String, wsPaste As Worksheet

'make sure these are exactly the same as your workbook. Case sensative
    Set wsPull = ThisWorkbook.Sheets("sheet 2")
    Set wsPaste = ThisWorkbook.Sheets("sheet1")
    
    For Each aCell In Intersect(wsPull.UsedRange, wsPull.Range("Q:Q")).Cells
        theCellValue = aCell.Value2
        If InStr(1, theCellValue, tangoText, vbTextCompare) > 0 Then
            aCell.Offset(0, 1).Value2 = theCellValue
            wsPaste.Cells(Rows.Count, 2).End(xlUp).Offset(1, 0).Value = theCellValue
        End If
    Next aCell

End Sub

【讨论】：

谢谢！这非常有帮助。这正是我需要的，除了它没有在正确的单元格中发布 IF 查找结果。我尝试将 XLup 切换到 XLdown 并出现错误，编辑了原始帖子以分享我面临的问题。我不认为XLdown经常被使用？