WorksheetFunction 到 Application.Worksheetfunction

Question

我手頭有一個相當復雜的公式。 到目前為止，我一直在使用Range.Formula2R1C1 ，但是速度非常慢。

ws.Cell (3, 14)中的原始公式為：

=TEXTJOIN(", ";TRUE;IF(IFERROR(MATCH(tblPO[PO_MAT];IF(B3=tblPO[PROJECT];tblPO[PO_MAT];"");0);"")=MATCH(ROW(tblPO[PO_MAT]);ROW(tblPO[PO_MAT]));tblPO[PO_MAT];""))

代碼

Public Function WriteComplexFormulas()

    
    Dim ws As Worksheet, ws2 As Worksheet
    Set ws = ThisWorkbook.Worksheets("Orders")
    Set ws2 = ThisWorkbook.Worksheets("PO")
    
    
    Dim obj As ListObject
    Set obj = ws.ListObjects("tblOrders")
    
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual

    
 
    ws.Cells(3, 14).Formula2R1C1 = "=TEXTJOIN("", "",TRUE,IF(IFERROR(MATCH(tblPO[PO_MAT],IF(RC[-12]=tblPO[PROJECT],tblPO[PO_MAT],""""),0),"""")=MATCH(ROW(tblPO[PO_MAT]),ROW(tblPO[PO_MAT])),tblPO[PO_MAT],""""))"

    
    For j = 1 To obj.DataBodyRange.Rows.Count
        ws.Cells(j + 2, 14).Value = ws.Cells(j + 2, 14).Value
    Next j
        
    Application.ScreenUpdating = True
    Application.Calculation = xlCalculationAutomatic
    
End Function

一個特定 SO 的表順序如下所示：

當前工作表函數的結果將每個'PROJECT'的'PO_MAT'列中的所有結果作為字符串返回： "RELAYXX1, RELAYXY2, RELAYXZ3"

現在，長期存在的原因當然是非常耗費資源的公式。 ws.cell(3,14)是表格中的第一個單元格。 因此，公式被寫入（自動填充）到大約 2500 行數據。 這肯定需要處理時間。

我不知道如何繼續讓它運行得更快，因為Application.Worksheetfunction沒有"IF"-statement 。

關於如何用 VBA 替換此函數的任何指示？ 如果有任何幫助，我在 Python 中實現了相同的結果：

def modifyDict(df):
        df['PROJECT'] = (df['SD_DOC'] + '-' +  df['SD_ITM'])
        df= df[['PROJECT', 'PO_MAT']]
       
        df = pd.DataFrame(df)
        dict_ = df.groupby('PROJECT')['PO_MAT'].agg(list).to_dict()

        keys_values = dict_.items()
        outputDict = {str(key): str(value) for key, value in keys_values}

        output = pd.DataFrame.from_dict(outputDict,orient='index').reset_index()
        output.columns = np.arange(len(output.columns))

        output.rename(index=str).index
        output.columns = ['PROJECT','PO_MAT']

        return output

明確要求

期望的結果是一個字符串，包含表中給定鍵的所有匹配項。

這兩個表是：

'Materials Ordered' 列說明了所需的輸出：與在最右邊的表中找到的每個鍵相關聯的所有值的串聯，與最左邊的表鍵鏈接。

Answer 1

請使用下一個解決方案。 它應該非常快，使用數組、字典並立即刪除處理過的數組內容。 它不應該用作 UDF 函數（從單元格調用）。 您應該按原樣運行代碼，它將在相應的表格列中帶來（我理解的）需要的內容：

Sub bringProjectsMaterials()
  Dim ws As Worksheet, ws2 As Worksheet, tblOrd As ListObject, tblPO As ListObject
  Dim arrPr1, arrPr2, arrO, arrMat, arrMatO, dict As Object, i As Long
  
  Set ws = ThisWorkbook.Worksheets("Orders")
  Set ws2 = ThisWorkbook.Worksheets("PO")
  Set tblOrd = ws.ListObjects("tblOrders")
  Set tblPO = ws2.ListObjects("tblPO")

  arrPr1 = tblOrd.ListColumns("PROJECT").DataBodyRange.Value2 'place the ranges in arrays, for faster iteration/processing
  arrPr2 = tblPO.ListColumns("PROJECT").DataBodyRange.Value2
  arrMat = tblPO.ListColumns("PO_MAT2").DataBodyRange.Value2
  
  'build the dictionary of unique orders in tblPO with PROJECT as keys and PO_MAT as strings to be returned
  Set dict = CreateObject("Scripting.Dictionary")
  For i = 1 To UBound(arrPr2)
        If Not dict.Exists(arrPr2(i, 1)) Then
           dict(arrPr2(i, 1)) = arrMat(i, 1)
        Else
            dict(arrPr2(i, 1)) = dict(arrPr2(i, 1)) & "," & arrMat(i, 1)
        End If
  Next i
  'fill the array to keep the processed result:
  ReDim arrMatO(1 To UBound(arrPr1), 1 To 1)
  For i = 1 To UBound(arrPr1)
        arrMatO(i, 1) = dict(arrPr1(i, 1))
  Next i
  'drop the processed array content in the necessary column:
   tblOrd.ListColumns("Materials Ordered").DataBodyRange.Value2 = arrMatO
End Sub
MsgBox "Ready..."