excelvbarangedefinitiontype-mismatch

Set range to read values from one worksheet and write to another

The script is intended to:

  1. Read values from column LADUNGSNUMMER in the worksheet NVL cell by cell.
  2. Find each value in column Transport of the worksheet DATA.
  3. Read the corresponding values from column Faktura (1:n relationship).
  4. Concatenate these values into a string.
  5. Write the concatenated string into column EX-Fakturen of the worksheet NVL.

I encounter an error

Types incompatible

at the line:

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

However, I can retrieve the range successfully because Debug.Print returns the correct result. The issue seems to be with the definition.

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

Screenshots

Debugging delivers

Error 13

Solution

  • A Delimited VBA Lookup in Excel (Structured) Tables

    enter image description here

    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