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