Arrays 应用程序定义或对象定义错误-调整Ubound、Application.Transpose的大小

我对我们为特定任务编写的小代码有问题。简而言之，任务是获取两列的输入；（A） 包含具有ProductsNumber（和重复项）和（B）的行，其中包含该特定productnumber的对应值

我们不希望有100.000行，而是希望在列A中有一个唯一的productnumber，在列B中有相应的（连接的）值。这已经实现了

我在堆栈中找到了大部分代码，并对其进行了一些更改。我很想链接，但记不起我到底从哪里得到的-对不起！ 现在，我们有很多行，因此原始代码遇到了问题，因为循环变量（i）被调暗为整数

• 为了解决这个问题，我很快把它改成了Long。但是，这给我带来了另一个问题：“运行时错误‘1004’：应用程序定义的错误或对象定义的错误”

调试告诉我是下面的注释部分出现了问题，但我无法修复它

非常感谢您的帮助。提前非常感谢你

---

最后一排

lastRow = Range("A" & Rows.Count).End(xlUp).Row

将电子邮件格式化为文本

Range("E1:E20000").NumberFormat = "@"

在完成任何进一步工作之前，请清除工作表

Worksheets("Sheet1").Range("D2:E20000").ClearContents
Set dc = CreateObject("Scripting.Dictionary")
inputArray = WorksheetFunction.Transpose(Sheets(1).Range("A2:B" & lastRow).Value)

   '-- assuming you only have two columns - otherwise you need two loops
   For i = LBound(inputArray, 2) To UBound(inputArray, 2)
        If Not dc.Exists(inputArray(1, i)) Then
            dc.Add inputArray(1, i), inputArray(2, i)
        Else
            dc.Item(inputArray(1, i)) = dc.Item(inputArray(1, i)) _
            & "," & inputArray(2, i)
        End If
   Next i

'--output into sheet
Sheets(1).Range("D2").Resize(UBound(dc.keys) + 1) = _
          Application.Transpose(dc.keys)

下期

---

也许是双重转置。尝试此版本，看看是否适合您：

    Sub DictMatch()
        Dim arr, j As Long, dict As Object
        arr = Sheet1.Range("A1").CurrentRegion.Value2 'load source
        Sheet1.Range("A1").CurrentRegion.ClearContents
        Set dict = CreateObject("Scripting.Dictionary") 'create dictionary lateB
        With dict 'used because I'm to lazy to retype dict everywhere :)
            
            For j = 1 To UBound(arr) 'traverse source
                If Not .Exists(arr(j, 1)) Then 'set key if I don't have it yet in dict
                    .Add Key:=arr(j, 1), Item:=arr(j, 2)
                Else
                    dict(arr(j, 1)) = dict(arr(j, 1)) & "," & arr(j, 2)
                End If
                Debug.Print arr(j, 1), dict(arr(j, 1))
            Next j
        End With
        
        With Sheet1 'dump target array to sheet
            .Cells(1, 1).Resize(dict.Count, 1).Value2 = Application.Transpose(dict.keys)
            .Cells(1, 2).Resize(dict.Count, 1).Value2 = Application.Transpose(dict.Items)
        End With
    End Sub

---

我怀疑您在项目中存储了一些长文本。在某些版本的Excel中，

Transpose

无法解决这一问题，因此最好编写自己的转置函数。我也不太清楚为什么要转置最初的输入阵列——对我来说，这似乎是浪费时间。非常感谢。我相信你是对的。我尝试了下面的方法，结果得到了相同的错误。有些项目中确实包含大量文本。这可能就是问题所在。你好！首先，非常感谢您尝试一下。不幸的是，我最终还是出现了运行时错误“1004”：（你能发布一些示例数据吗？如果我能重现错误，我会看一看。

Sheets(1).Range("E2").Resize(UBound(dc.items) + 1) = _
          Application.Transpose(dc.items)

Set dc = Nothing

End Sub

    Sub DictMatch()
        Dim arr, j As Long, dict As Object
        arr = Sheet1.Range("A1").CurrentRegion.Value2 'load source
        Sheet1.Range("A1").CurrentRegion.ClearContents
        Set dict = CreateObject("Scripting.Dictionary") 'create dictionary lateB
        With dict 'used because I'm to lazy to retype dict everywhere :)
            
            For j = 1 To UBound(arr) 'traverse source
                If Not .Exists(arr(j, 1)) Then 'set key if I don't have it yet in dict
                    .Add Key:=arr(j, 1), Item:=arr(j, 2)
                Else
                    dict(arr(j, 1)) = dict(arr(j, 1)) & "," & arr(j, 2)
                End If
                Debug.Print arr(j, 1), dict(arr(j, 1))
            Next j
        End With
        
        With Sheet1 'dump target array to sheet
            .Cells(1, 1).Resize(dict.Count, 1).Value2 = Application.Transpose(dict.keys)
            .Cells(1, 2).Resize(dict.Count, 1).Value2 = Application.Transpose(dict.Items)
        End With
    End Sub