Проблема Создание макроса автозаполнения с помощью функции VBA

Question

У меня возникла проблема с созданием макроса, который будет автозаполнять функцию VBA с именем «FindMyOrderNumber». Каждый раз, когда я запускаю макрос для автозаполнения «FindMyOrderNumber», заполняется только первая ячейка в столбце.

Эта функция будет искать номер заказа в столбце A (A1) и возвращать имя рабочего листа, которое может быть найдено B (B1).

Option Explicit 
Function FindMyOrderNumber(strOrder As String) As String 

    Dim ws As Worksheet 
    Dim rng As Range 

    For Each ws In Worksheets 
     If ws.CodeName <> "Sheet3" Then 
      Set rng = Nothing 
      On Error Resume Next 
       Set rng = ws.Cells.Find(What:=strOrder, LookAt:=xlWhole) 
      On Error GoTo 0 
      If Not rng Is Nothing Then 
       FindMyOrderNumber = ws.Name 
       Exit For 
      End If 
     End If 
    Next 

    Set rng = Nothing 
    Set ws = Nothing 

End Function 

Я создал этот макрос ввести свой VBA функцию "= findmyordernumber (a1)" в ячейке B1 затем автозаполнение столбца B.

Sub AutofillVBAFunction() 

    Range("B1").Select 
    ActiveCell.FormulaR1C1 = "=FindMyOrderNumber(RC[-1])" 
    Selection.Autofill Destination:=Range("B1:B68") 
    Range("B1:B68").Select 
End Sub 

После того как я запустить этот макрос только B1 заполняются.

Извините, если это было обсуждено, я новичок, и я попробовал How to fill-up cells within a Excel worksheet from a VBA function? и другие вопросы, и я не смог применить его к моей проблеме.

Пожалуйста, помогите

Answer 1

Добавить application.volatile функции, таким образом она просчитывает как изменения листа.

Function FindMyOrderNumber(strOrder As String) As String 

    Dim ws As Worksheet 
    Dim rng As Range 
    Application.Volatile 
    For Each ws In Worksheets 
     If ws.CodeName <> "Sheet3" Then 
      Set rng = Nothing 
      On Error Resume Next 
      Set rng = ws.Cells.Find(What:=strOrder, LookAt:=xlWhole) 
      On Error GoTo 0 
      If Not rng Is Nothing Then 
       FindMyOrderNumber = ws.Name 
       Exit For 
      End If 
     End If 
    Next 

    Set rng = Nothing 
    Set ws = Nothing 

End Function 

Это также не помешает рассчитать лист, когда вы добавите формулу в диапазон.

Sub Button1_Click() 
    Dim Rws As Long, Rng As Range 
    Rws = Cells(Rows.Count, "A").End(xlUp).Row 
    Set Rng = Range(Cells(1, 2), Cells(Rws, 2)) 
    Rng = "=FindMyOrderNumber(RC[-1])" 
End Sub