Question

我需要帮助。我需要搜索我的工作表并找到一个特定的单词（“物质”），然后将单元格2列中的值复制到另一张工作表中。

例如，在Sheet1中，如果在A4中找到“物质”，则从C4复制值并将其粘贴到Sheet2的最后一个填充行下。我需要在整个工作表中继续这样做。 “物质”不是顺序出现的，而是总是出现在A列中（即，第一次出现的可能是A4，下一个可能出现在A16中）。

这是我到目前为止所拥有的：

Dim Cell, cRange As Range
    Set cRange = Sheets("Sheet1").Range("A1:A75")
    For Each Cell In cRange
    FindCounter = 0

    If Cell.Value = "Substances" Then
        FindCounter = FindCounter + 1
        Sheets("Sheet1").Cell.Value(0, 2).Copy
        Sheets("Sheet2").Range("A" & Sheets("Sheet2").Cells(Rows.Count, "A").End(xlUp).Row + 1).PasteSpecial xlPasteValues
    End If
    Next

    Application.ScreenUpdating = True

Answer 1

尝试一下。查找比循环更有效（出于我从未完全理解的原因）。

Sub x()

Dim rFind As Range, s As String

With Sheets("Sheet1").Range("A1:A75")
    Set rFind = .Find(What:="Substances", Lookat:=xlWhole, MatchCase:=False, SearchFormat:=False)
    If Not rFind Is Nothing Then
        s = rFind.Address
        Do
            Sheets("Sheet2").Range("A" & Sheets("Sheet2").Cells(Rows.Count, "A").End(xlUp).Row + 1).Value = rFind.Offset(, 2).Value
            Set rFind = .FindNext(rFind)
         Loop While rFind.Address <> s
    End If
End With

End Sub

Answer 2

替代使用for循环：

Sub Copy()

    Dim i As Long
    Dim lRow1 As Long, lRow2 As Long
    Dim ws1 As Worksheet, ws2 As Worksheet

    'set worksheets
    Set ws1 = Sheets("Sheet1")
    Set ws2 = Sheets("Sheet2")

    'set last row to search for substances
    lRow1 = ws1.Range("A" & ws1.Rows.Count).End(xlUp).Row
    'start for loop
    For i = 1 To lRow1
        If ws1.Range("A" & i).Value = "Substances" Then
            'assuming you want to paste into column A on sheet 2
            'adjust as you need to
            lRow2 = ws2.Range("A" & ws2.Rows.Count).End(xlUp).Row + 1

            ws2.Range("A" & lRow2).Value = ws1.Range("A" & i).Offset(0, 2).Value
        End If
    Next
    'clear objects
    Set ws1 = Nothing
    Set ws2 = Nothing

End Sub

查找文本并将相邻的单元格复制到其他工作表

2 个答案: