копировать и вставлять определенную ячейку (используя .find) в массиве рабочих таблиц с помощью vba

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 EDT) Добавлены операторы отладки, которые помогут вам; Нужно добавить ссылку на «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, если применяется к рабочим листам для продления текущего выбора, извините за это!