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选项，对不起！

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

2 个答案: