提取不重复计数时，运行出现下标越界

梦远方

提取不重复计数时，运行出现下标越界，请帮忙看下，代码哪里有误？
Sub 条件求和()
Dim arr1(1 To 4309, 1 To 2)
Set endr = Cells(Rows.Count, "B").End(xlUp)
arr = Sheet1.Range([b2], endr)
For i = 1 To endr.Row - 1
    For j = 1 To UBound(arr1)
        If arr(i, 1) = arr1(j, 1) Then
            arr1(j, 2) = arr(i, 2) + arr1(j, 2)
            GoTo 100
        End If
    Next j
        k = k + 1
        arr1(k, 1) = arr(i, 1)
        arr1(k, 2) = arr(i, 2)
100:
Next i
Cells.[k2].Resize(k, 2) = arr1
End Sub

kankan1030

1. Sub Test()
   
2.     Dim Conn As Object, Rst As Object
   
3.     Dim strConn As String, strSQL As String
   
4.     Dim i As Integer, PathStr As String
   
5.     Set Conn = CreateObject("ADODB.Connection")
   
6.     Set Rst = CreateObject("ADODB.Recordset")
   
7.     PathStr = ThisWorkbook.FullName
   
8.     Select Case Application.Version * 1
   
9.     Case Is <= 11
   
10.         strConn = "Provider=Microsoft.Jet.Oledb.4.0;Extended Properties=excel 8.0;Data source=" & PathStr
    
11.     Case Is >= 12
    
12.         strConn = "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & PathStr & ";Extended Properties=""Excel 12.0;HDR=YES"";"""
    
13.     End Select
    
14.     strSQL = "select 名称 , sum(金额)as 合计金额  from [sheet1$b1:c5000] group by 名称"
    
15.     Conn.Open strConn
    
16.     Set Rst = Conn.Execute(strSQL)
    
17.     With Sheet1
    
18.         
    
19.         For i = 0 To Rst.Fields.Count - 1
    
20.             .Cells(1, i + 11) = Rst.Fields(i).Name
    
21.         Next i
    
22.         .Range("k2").CopyFromRecordset Rst
    
23.         .Cells.EntireColumn.AutoFit
    
24.     End With
    
25.     Rst.Close
    
26.     Conn.Close
    
27.     Set Conn = Nothing
    
28.     Set Rst = Nothing
    
29. End Sub
    

复制代码

用SQL更简单，无需动脑。

huzijun

Sub 条件求和()
Dim arr1(1 To 4309, 1 To 2)
Set endr = Cells(Rows.Count, "C").End(xlUp)
arr = Sheet1.Range([b2], endr)
For i = 1 To endr.Row - 1
    For j = 1 To UBound(arr1)
        If arr(i, 1) = arr1(j, 1) Then
            arr1(j, 2) = arr(i, 2) + arr1(j, 2)
            GoTo 100
        End If
    Next j
        k = k + 1
        arr1(k, 1) = arr(i, 1)
        arr1(k, 2) = arr(i, 2)
100:
Next i
[k2].Resize(k, 2) = arr1
End Sub

按你的方法改了，但是更推荐用字典。

LMY123

试试，字典或ADO实现分类汇总

huzijun

Sub 条件求和字典法()
    Set d = CreateObject("scripting.dictionary")
    arr = Range("B1").CurrentRegion
    ReDim brr(1 To UBound(arr), 1 To 2)
    For i = 1 To UBound(arr)
        s = arr(i, 1)
        If d(s) = "" Then
            k = k + 1
            d(s) = k
            brr(k, 1) = s
            brr(k, 2) = arr(i, 2)
        Else
            brr(d(s), 2) = arr(i, 2) + brr(d(s), 2)
        End If
    Next
    [K1].Resize(k, 2) = brr
End Sub

字典的方法，参考一下。

梦远方

huzijun 发表于 2018-8-22 16:02
Sub 条件求和字典法()
    Set d = CreateObject("scripting.dictionary")
    arr = Range("B1").Curren ...

谢谢！  请问我的那段代码不能运行是错在哪里呢？

梦远方

kankan1030 发表于 2018-8-22 15:53
用SQL更简单，无需动脑。

可是   不会··~~

huzijun

梦远方 发表于 2018-8-23 14:11
谢谢！  请问我的那段代码不能运行是错在哪里呢？

第三行的 B 改成了 C
倒数第二行 去掉了Cells.

梦远方

huzijun 发表于 2018-8-23 14:57
第三行的 B 改成了 C
倒数第二行 去掉了Cells.

嗯嗯  我的意思是为什么不能是B

huzijun

梦远方 发表于 2018-8-23 15:45
嗯嗯  我的意思是为什么不能是B

因为你原来的代码只把B列放进了数组。。应该要把2列都放进去