VBA 脚本从一个工作表读取值并写入另一个工作表（设置范围问题）

Question

我正在努力处理 VBA 子例程，希望获得一些帮助。该脚本旨在执行以下任务：

1. 从工作表“NVL”中的“LADUNGSNUMMER”列逐个单元格读取值。
2. 在工作表“DATA”的“Transport”列中查找每个值。
3. 从“Faktura”列中读取相应的值（1:n 关系）。
4. 将这些值连接成一个字符串。
5. 将连接的字符串写入工作表“NVL”的“EX-Fakturen”列。

不幸的是，我在该行遇到“类型不兼容”错误：

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 查找

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(SRC_TABLE_INDEX)
        dlData = .ListColumns(DST_LOOKUP_COLUMN_TITLE).DataBodyRange.Value
        Set drrg = .ListColumns(DST_RETURN_COLUMN_TITLE).DataBodyRange
    End With
    
    Dim drCount As Long: drCount = UBound(dlData, 1)
    Dim dict As Object: Set dict = CreateObject("Scripting.Dictionary")
    
    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