使用vba在工作表数组中复制并粘贴特定单元格（使用.find）

Question

下面的代码根据标签的颜色选择标签。 每张纸的格式相同，只是包含不同的值。 我正在尝试使用.find和offset查找一个特定的单元格（它对应于当前会计周加一），然后将该单元格复制并粘贴为值而不是公式。 下面的代码选择所需的选项卡，并找到正确的单元格，但不会将该单元格复制并粘贴为值。 我试图不专门命名工作表，因为此代码将用于多个工作簿且所有工作表具有不同的选项卡名称。

Sub freeze()

Dim ws As Worksheet
Dim strg() As String
Dim count As Integer
count = 1

For Each ws In Worksheets
    If ws.Tab.Color = 255 Then
        ReDim Preserve strg(count) As String
        strg(count) = ws.Name
        count = count + 1
    Else
    End If

Next ws
Sheets(strg(1)).Select

Dim aCell As Range
Set aCell = Range("B9:B79").Find(What:=Worksheets("EmailTemplate").Range("A1").Value)

If Not aCell Is Nothing Then
Sheets(strg(1)).aCell.Select
    ActiveCell.Offset(0, 6).Select
    Selection.copy
    Selection.PasteSpecial xlPasteValues
Else
End If

   For I = 2 To UBound(strg)
    Sheets(strg(I)).Select False

Next I
End Sub 

谢谢

Answer 1

更新＃2（美国东部时间星期日11:15）添加了调试语句以帮助您； 需要在“查找”代码中添加对“ ActiveSheet”的引用，将遍历所有“红色”工作表，查找匹配项（如果有）并复制/粘贴值。 调试代码将显示红色选项卡名称，搜索值，结果，公式，值

Option Explicit

Sub freeze()

Dim ws      As Worksheet
Dim aCell   As Range
Dim strg()  As String
Dim count   As Integer
Dim i       As Integer

count = 0

' Get each RED sheet
For Each ws In Worksheets
    If ws.Tab.Color = 255 Then                      ' Find only RED tabs
        Debug.Print "-----------------------------------------------------------------------"
        Debug.Print "Name of Red Sheet: '" & ws.Name & "'"        ' Debug...
        'ReDim Preserve strg(count + 1) As String
        'count = count + 1                           ' This code not necessary as you can just reference the ws.name
        'strg(count) = ws.Name                       ' Ditto

        Sheets(ws.Name).Select
        Set aCell = ActiveSheet.Range("B9:B79").Find(What:=Worksheets("EmailTemplate").Range("A1").value)
        If Not aCell Is Nothing Then
            ActiveSheet.Cells(aCell.Row, aCell.column).Select
            ActiveCell.Offset(0, 6).Select      ' Offset same row, + 6 columns
            Debug.Print "Found Match for '" & Worksheets("EmailTemplate").Range("A1").value & _
                "' in: R" & aCell.Row & ":C" & aCell.column & vbTab & "Formula: '" & ActiveCell.Formula & "'; Value: '" & ActiveCell.value & "'"
            ' Weird, but was unable to use 'aCell.Select' 2nd time thru loop
            Selection.Copy
            Selection.PasteSpecial xlPasteValues
        Else
            Debug.Print "Did NOT find a match for: '" & Worksheets("EmailTemplate").Range("A1").value & "' in sheet '" & ws.Name & "'"
        End If
        Application.CutCopyMode = False         ' Unselect cell
    End If
Next ws

End Sub

Answer 2

您不能这样做：

Sheets(strg(1)).aCell.Select

该工作表已经存储在范围对象aCell 。 您也不应该使用select并且不需要粘贴值。 这是我会做的：

Dim aCell As Range
Set aCell = Sheets(strg(1)).Range("B9:B79").Find(What:=Worksheets("EmailTemplate").Range("A1").Value)

If Not aCell Is Nothing Then
    aCell.Offset(0, 6).Value = aCell.Offset(0, 6).Value 
End If

我不明白您想通过第二个循环实现什么。 .Select不接受我认为的论点？ 编辑 ：实际上。如果应用于工作表以扩展当前选择， .Select会接受replace选项，对此感到抱歉！