使用范围中的值作为变量

Question

我想在一个单独的工作表（“Items”）上使用一系列值作为搜索条件，而不是硬编码要查找的值（“1234”）。

我还想用相同的值替换目标表。

例如，范围中的第一个值可能是“8754”，我希望代码查找此值，然后将列A，B，C，F和包含该值的单元格粘贴到工作表上“ 8754" 。 （我已经创建了所有工作表）

TIA

Sub Test()
Dim Cell As Range

With Sheets("Sheet1") 'Sheet with data to check for value
For Each Cell In .Range("H1:H" & .Cells(.Rows.Count, "H").End(xlUp).Row)
    pos = InStr(Cell.Value, "1234")
    If pos > 0 Then
        NextFreeRow = Sheets("Sheet2").Cells(Sheets("Sheet2").Rows.Count, 
"A").End(xlUp).Row + 1
         'get the next empty row to paste data to
        .Range("A" & Cell.Row & ",B" & Cell.Row & ",C" & Cell.Row & ",F" & 
Cell.Row & "," & Cell.Address).Copy Destination:=Sheets("Sheet2").Range("A" & NextFreeRow)
        End If
    Next Cell
End With
End Sub

Answer 1

Option Explicit

Public Sub Test()
    Dim ws1 As Worksheet, ws2 As Worksheet, ws3 As Worksheet, lr1 As Long, lr2 As Long
    Dim luArr As Variant, luVal As Variant, r As String, itm As Variant, itmRow As Long

    Set ws1 = ThisWorkbook.Worksheets("Data")       'Sheet with data to check for value
    Set ws3 = ThisWorkbook.Worksheets("Items")      'LookUp values
    luArr = ws3.UsedRange.Columns("A")              'LookUp column
    lr1 = ws1.Cells(ws1.Rows.Count, "H").End(xlUp).Row

    Dim findRng As Range, copyRng As Range, toRng As Range, fr As Long
    Set findRng = ws1.Range("H1:H" & lr1)

    On Error Resume Next    'Expected error: sheet not found
    Application.ScreenUpdating = False
    For Each luVal In luArr
        Set ws2 = Nothing
        Set ws2 = ThisWorkbook.Worksheets(luVal)    'Copy to
        If ws2 Is Nothing Then
            Err.Clear
        Else
            itm = Application.Match(luVal, findRng, 0)
            If Not IsError(itm) Then
                findRng.AutoFilter Field:=1, Criteria1:="*" & luVal & "*"
                fr = IIf(findRng.SpecialCells(xlCellTypeVisible).Cells.Count = 1, 1, 2)
                With ws1.UsedRange
                    Set copyRng = .Range("A" & fr & ":C" & lr1)
                    Set copyRng = Union(copyRng, .Range("F" & fr & ":F" & lr1))
                    Set copyRng = Union(copyRng, .Range("H" & fr & ":H" & lr1))
                End With
                lr2 = ws2.Cells(ws2.Rows.Count, "A").End(xlUp).Row + 1
                copyRng.Copy
                ws2.Cells(lr2, 1).PasteSpecial
                findRng.AutoFilter
            End If
        End If
    Next
    Application.ScreenUpdating = True
End Sub

Sheet 1中

产品

之前（表A1，A2和A3）

在

Answer 2

这使用FIND而不是FILTER来复制正确的行 Main过程定义了您要搜索的范围以及要搜索的值。 FindValues过程找到该值并将其复制到正确的工作表。

这假定Sheet3!A1:A3包含要搜索的唯一值列表，这些值可在Sheet1!H:H中找到。
它还假设所有工作表都已存在。

Public Sub Main()

    Dim rToFind As Range
    Dim rValue As Range
    Dim rSearchRange As Range

    With ThisWorkbook

        'Update to the range being searched.
        With .Worksheets("Sheet1")
            Set rSearchRange = .Range("H1", .Cells(.Rows.Count, 8).End(xlUp))
        End With

        'Update to the range containing the values to be searched for.
        Set rToFind = .Worksheets("Sheet3").Range("A1:A3")

    End With

    'Passe each of the values to be searched to the FindValues procedure.
    For Each rValue In rToFind
        FindValues rValue, rSearchRange
    Next rValue


'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'    Alternative method to look for hard-coded values.
'    `ValuesToFind` in FindValues procedure will needed changing to a Variant.
'
'    Dim vAlternativeSearch As Variant
'    Dim vAlternativeValue As Variant
'    vAlternativeSearch = Array(1475, 1683, 219)
'
'    For Each vAlternativeValue In vAlternativeSearch
'        FindValues vAlternativeValue, rSearchRange
'    Next vAlternativeValue

End Sub

Public Sub FindValues(ValueToFind As Range, RangeToSearch As Range)

    Dim rFound As Range
    Dim sFirstAddress
    Dim rLastUsedCell As Range

    'Find the next available row on the referenced sheet.
    With ThisWorkbook.Worksheets(CStr(ValueToFind))
        Set rLastUsedCell = .Range("A1", .Cells(.Rows.Count, 1).End(xlUp)).Offset(1)
    End With

    With RangeToSearch

        'Find the first value.
        Set rFound = .Find(What:=ValueToFind, _
                           After:=RangeToSearch.Cells(RangeToSearch.Cells.Count), _
                           LookAt:=xlPart, _
                           SearchDirection:=xlNext)

        'If the first value exists then remember the address, copy the cells to the
        'correct sheet and look for the next row with the same value.  Stop when
        'it reaches the first address again.
        If Not rFound Is Nothing Then
            sFirstAddress = rFound.Address
            Do
                'You may have to muck around with this to get the correct range to copy.
                'If rFound is in column H this will copy columns B:D and F.
                Union(rFound.Offset(, -6).Resize(, 3), rFound.Offset(, -2)).Copy Destination:=rLastUsedCell
                Set rLastUsedCell = rLastUsedCell.Offset(1)
                Set rFound = .FindNext(rFound)
            Loop While rFound.Address <> sFirstAddress
        End If
    End With

End Sub  

编辑1：

您说工作表已经存在，但在您的评论中，您说要将其放入一张全新的工作表中 要添加新工作表，请添加以下功能：

Public Function WorkSheetExists(SheetName As String, Optional WrkBk As Workbook) As Boolean
    Dim wrkSht As Worksheet

    If WrkBk Is Nothing Then
        Set WrkBk = ThisWorkbook
    End If

    On Error Resume Next
        Set wrkSht = WrkBk.Worksheets(SheetName)
        WorkSheetExists = (Err.Number = 0)
        Set wrkSht = Nothing
    On Error GoTo 0
End Function

然后在FindValues过程中的变量声明后直接添加此代码：

Dim wrkSht As Worksheet
If Not WorkSheetExists(CStr(ValueToFind)) Then
    Set wrkSht = ThisWorkbook.Worksheets.Add
    wrkSht.Name = CStr(ValueToFind)
End If  

编辑2：

此更新代码搜索Q：Z列，返回A：L以及找到的单元格中的值 要从原始代码更新，我必须将rSearchRange更改为从Q1到第26列，并更新复制/粘贴行以返回正确的范围。

Public Sub Main()

    Dim rToFind As Range
    Dim rValue As Range
    Dim rSearchRange As Range

    With ThisWorkbook

        'Update to the range being searched.
        With .Worksheets("Data")
            Set rSearchRange = .Range("Q1", .Cells(.Rows.Count, 26).End(xlUp))
        End With

        'Update to the range containing the values to be searched for.
        Set rToFind = .Worksheets("Items").Range("A1:A2")

    End With

    'Passe each of the values to be searched to the FindValues procedure.
    For Each rValue In rToFind
        FindValues rValue, rSearchRange
    Next rValue

End Sub

Public Sub FindValues(ValueToFind As Range, RangeToSearch As Range)

    Dim rFound As Range
    Dim sFirstAddress
    Dim rLastUsedCell As Range

    'Find the next available row on the referenced sheet.
    With ThisWorkbook.Worksheets(CStr(ValueToFind))
        Set rLastUsedCell = .Range("A1", .Cells(.Rows.Count, 1).End(xlUp)).Offset(1)
    End With

    With RangeToSearch

        'Find the first value.
        Set rFound = .Find(What:=ValueToFind, _
                           After:=RangeToSearch.Cells(RangeToSearch.Cells.Count), _
                           LookAt:=xlPart, _
                           SearchDirection:=xlNext)

        'If the first value exists then remember the address, copy the cells to the
        'correct sheet and look for the next row with the same value.  Stop when
        'it reaches the first address again.
        If Not rFound Is Nothing Then
            sFirstAddress = rFound.Address
            Do
                'Parent of RangeToSeach range which will be the Data worksheet.
                With .Parent
                    'Copy columns A:L (columns 1 to 12) and the found cell.
                    Union(.Range(.Cells(rFound.Row, 1), .Cells(rFound.Row, 12)), rFound).Copy Destination:=rLastUsedCell
                End With
                Set rLastUsedCell = rLastUsedCell.Offset(1)
                Set rFound = .FindNext(rFound)

            Loop While rFound.Address <> sFirstAddress
        End If
    End With

End Sub