设置范围以从一个工作表读取值并写入另一个工作表

Question

该脚本的目的是：

1. 从工作表

   LADUNGSNUMMER

   中的第

   NVL

   列逐个单元格读取值。
2. 在工作表

   Transport

   的第

   DATA

   列中查找每个值。
3. 从第

   Faktura

   列中读取相应的值（1:n 关系）。
4. 将这些值连接成一个字符串。
5. 将连接的字符串写入工作表

   EX-Fakturen

   的第

   NVL

   列。

我遇到错误

类型不兼容

在线：

Set transportColumn = .Range("Transport", .Cells(.Rows.Count, "Transport").End(xlUp)

但是，我可以成功检索范围，因为

Debug.Print

返回了正确的结果。问题似乎在于定义。

Sub NVLFakturenLaden()
    Dim ws As Worksheet
    Dim loadNumberRange As Range
    Dim cell As Range
    Dim fakturaValue As String
    Dim counter As Long
    Dim transportColumn As Range
    Dim deliveryColumn As Range
    Dim deliveryCell As Range
    Dim deliveryValue As String
    Dim result As String
    
    ' Set the worksheet with the data
    Set ws = ThisWorkbook.Sheets("NVL")
    
    ' Define the range based on the named range "LADUNGSNUMMER"
    Set loadNumberRange = ws.Range("LADUNGSNUMMER")
    
    ' Initialize the counter
    counter = 0
    ' Loop through the cells in the named range "LADUNGSNUMMER"
    For Each cell In loadNumberRange
        ' Define the ranges for "Transport" and "Faktura" columns on the "DATA" worksheet
        With ThisWorkbook.Sheets("DATA")
            If Application.WorksheetFunction.CountA(.Range("Transport")) > 0 Then
                ' Define the range
                Debug.Print Application.WorksheetFunction.CountA(.Range("Transport"))
                Set transportColumn = .Range("Transport", .Cells(.Rows.Count, "Transport").End(xlUp))
            Else
                MsgBox "No data in the 'Transport' range.", vbExclamation
            End If
            If Application.WorksheetFunction.CountA(.Range("Faktura")) > 0 Then
                ' Define the range
                Set deliveryColumn = .Range("Faktura", .Cells(.Rows.Count, "Faktura").End(xlUp))
            Else
                MsgBox "No data in the 'Faktura' range.", vbExclamation
            End If
        End With
        
        ' Search for the value in the "Transport" column and concatenate corresponding "Faktura" values
        For Each deliveryCell In deliveryColumn
            If deliveryCell.value = cell.value Then
                deliveryValue = CStr(deliveryCell.value)
                
                ' Concatenate the "Faktura" value to the result
                If Len(result) > 0 Then
                    result = result & ", " & deliveryValue
                Else
                    result = deliveryValue
                End If
            End If
        Next deliveryCell
        
        ' Assign the result to the cell one column to the right of the current cell
        cell.Offset(0, 1).value = result
        
        ' Check if a Faktura was loaded
        If result <> "" Then
            counter = counter + 1
        End If
        
        ' Reset the result for the next iteration
        result = ""
    Next cell
    
    MsgBox "Factura loaded to " & counter & " transports.", vbInformation
End Sub

调试交付

错误13

Answer 1

Excel（结构化）表中的定界 VBA 查找

• 如果您有MS365、Office 2021，并且我不确定Office 2019，您可以在第

  EX_Fakturen

  列的第一个单元格中使用以下公式（先清除该列）：

  =TEXTJOIN(", ",,FILTER(Monitor[Faktura],Monitor[Transport]=[@LADUNGSNUMMER],""))
  

Sub LookupFakturas()

    Const SRC_SHEET_NAME As String = "Data"
    Const SRC_TABLE_INDEX As Long = 1
    Const SRC_LOOKUP_COLUMN_TITLE As String = "Transport"
    Const SRC_RETURN_COLUMN_TITLE As String = "Faktura"
    Const DST_SHEET_NAME As String = "NVL"
    Const DST_TABLE_INDEX As Long = 1
    Const DST_LOOKUP_COLUMN_TITLE As String = "LADUNGSNUMMER"
    Const DST_RETURN_COLUMN_TITLE As String = "EX_Fakturen"
    Const DELIMITER As String = ", "
    
    Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
    
    Dim slData As Variant, srData As Variant
    
    With wb.Sheets(SRC_SHEET_NAME).ListObjects(SRC_TABLE_INDEX)
        slData = .ListColumns(SRC_LOOKUP_COLUMN_TITLE).DataBodyRange.Value
        srData = .ListColumns(SRC_RETURN_COLUMN_TITLE).DataBodyRange.Value
    End With
    
    Dim drrg As Range, dlData As Variant
    
    With wb.Sheets(DST_SHEET_NAME).ListObjects(DST_TABLE_INDEX)
        dlData = .ListColumns(DST_LOOKUP_COLUMN_TITLE).DataBodyRange.Value
        Set drrg = .ListColumns(DST_RETURN_COLUMN_TITLE).DataBodyRange
    End With
    
    Dim dict As Object: Set dict = CreateObject("Scripting.Dictionary")
    Dim drCount As Long: drCount = UBound(dlData, 1)
    
    Dim r As Long
    For r = 1 To drCount
        dict(CStr(dlData(r, 1))) = r
    Next r
    Erase dlData
    
    Dim drData() As String: ReDim drData(1 To drCount, 1 To 1)
    
    Dim sStr As String, sr As Long, dr As Long
    
    For sr = 1 To UBound(slData, 1)
        sStr = CStr(slData(sr, 1))
        If dict.Exists(sStr) Then
            dr = dict(sStr)
            If drData(dr, 1) = vbNullString Then
                drData(dr, 1) = srData(sr, 1)
            Else
                drData(dr, 1) = drData(dr, 1) & DELIMITER & srData(sr, 1)
            End If
        End If
    Next sr
    
    drrg.Value = drData
    
    MsgBox "Fakturas looked up.", vbInformation
    
End Sub