DOSYA İndirmek/Yüklemek için ÜCRETLİ ALTIN ÜYELİK Gereklidir!
	Altın Üyelik Hakkında Bilgi
Çapları ayıkladıktan sonra VBA kodlarındaki gibi içiçe 2 adet For döngüsüyle işi bitirebilmeniz lazım .....
Neyse....
.
Private Sub CommandButton1_Click()
'   Haluk 23/02/2022
    Dim objRegEx As Object, RS As Object, uniqueCaps As New Collection
    Dim i As Integer, j As Integer, mySum As Double
    Dim capDizi(), adetDizi(), lboyDizi()
 
    Const adDouble = 5
 
    iCount = ListBox1.ListCount
    Set objRegEx = CreateObject("VBscript.RegExp")
 
    objRegEx.Pattern = "(\d+)"
    objRegEx.Global = True
 
    For i = 0 To iCount - 1
        myStr = ListBox1.List(i)
        If objRegEx.Test(myStr) Then
            ReDim Preserve capDizi(0 To i)
            ReDim Preserve adetDizi(0 To i)
            ReDim Preserve lboyDizi(0 To i)
         
            adetDizi(i) = objRegEx.Execute(myStr)(0)
            capDizi(i) = objRegEx.Execute(myStr)(1)
            lboyDizi(i) = objRegEx.Execute(myStr)(3)
        End If
    Next
 
    For i = 0 To UBound(capDizi)
        xMatch = CStr(capDizi(i))
        On Error Resume Next
            uniqueCaps.Add xMatch, xMatch
        On Error GoTo 0
    Next
    Set RS = CreateObject("ADODB.Recordset")
    RS.Fields.Append "Cap", adDouble
    RS.Fields.Append "Adet", adDouble
    RS.Fields.Append "Boy", adDouble
    RS.Open
    For i = LBound(capDizi) To UBound(capDizi)
        RS.AddNew
        RS.Fields("Cap").Value = capDizi(i)
        RS.Fields("Adet").Value = adetDizi(i)
        RS.Fields("Boy").Value = lboyDizi(i)
    Next
    RS("Cap").Properties("Optimize") = True
    RS.Update
    RS.MoveFirst
 
    For i = 1 To uniqueCaps.Count
        mySum = 0
        RS.Filter = "Cap = " & uniqueCaps.Item(i)
   
        For j = 0 To RS.RecordCount - 1
            mySum = mySum + RS.Fields("Adet") * RS.Fields("Boy")
            RS.MoveNext
        Next
   
        temp = temp & "Ø" & uniqueCaps.Item(i) & vbTab & " : " & mySum / 100 & " metre" & vbCrLf
    Next
    MsgBox "Metraj sonuçları: " & vbCrLf & vbCrLf & temp
    RS.Close
    Set RS = Nothing
End Sub