Soru Kodlamada Aralık tanımlama

[Orion1]

Forumda round diye arama yapınız.

 

[Korhan Ayhan]

@veyselemre beyin önerdiği kodu aşağıdaki gibi düzenleyince VALUE hataları ortadan kalkıyor.

Sub test2()
    Set sV = Sheets("VERİ KAYNAĞI")
    Set sA = Sheets("ANALİZ")
    sA.Range("D2:E" & Rows.Count).ClearContents
    liste = sV.Range("A2:E" & sV.Cells(Rows.Count, 1).End(3).Row).Value
    Dim w(1 To 2)

    With CreateObject("Scripting.Dictionary")
        For i = LBound(liste) To UBound(liste)
            For ii = 1 To 3
                al = Val(liste(i, ii))
                If .exists(al) Then
                    Z = .Item(al)
                    Z(1) = Z(1) + liste(i, 4)
                    Z(2) = Z(2) + liste(i, 5)
                    .Item(al) = Z
                Else
                    Z = w
                    Z(1) = liste(i, 4)
                    Z(2) = liste(i, 5)
                    .Item(al) = Z
                End If
            Next ii
        Next i
        sA.Select
        son = sA.Cells(Rows.Count, 1).End(3).Row
        For i = 2 To son
            Dim col As New Collection
            al = sA.Cells(i, 1)
            If al <> "" Then
                a = "="
                onc_nm = False
                For ii = 1 To Len(al)
                    b = Mid(al, ii, 1)
                    If IsNumeric(b) Or b = "." Then nm = True Else nm = False
                    If nm <> onc_nm Then
                        col.Add a
                        a = b
                    Else
                        a = a & b
                    End If
                    onc_nm = nm
                Next ii
                col.Add a

                f1 = ""
                f2 = ""
                If col.Count > 0 Then
                    For iii = 1 To col.Count
                        If IsNumeric(col(1)) And Len(col(1)) < 4 And InStr(col(1), ".") = 0 Then
                            If .exists(Val(col(1))) Then
                                Z = .Item(Val(col(1)))
                            Else
                                Z(1) = 0
                                Z(2) = 0
                            End If
                            f1 = f1 & Z(1)
                            f2 = f2 & Z(2)
                        Else
                            f1 = f1 & col(1)
                            f2 = f2 & col(1)
                        End If
                        col.Remove 1
                    Next iii
                End If
                sA.Cells(i, "D") = Evaluate(Replace(f1, ",", "."))
                sA.Cells(i, "E") = Evaluate(Replace(f2, ",", "."))
            End If
        Next i
    End With
End Sub

 

[dengeceteris]

Sayın Korhan, Sayın VeyselEmre, Sayın Orion1 hepinize ayrı ayrı tşk ederim.

 

[Korhan Ayhan]

Bende bir kod hazırlamıştım. Arşivde durması açısından paylaşıyorum.

Option Explicit

Sub Analiz()
    Dim S1 As Worksheet, S2 As Worksheet, Dizi As Object
    Dim Veri As Variant, Son As Long, X As Long, Y As Long, Say As Long
    Dim Hesap_Kodu As Long, Karakter_Say As Long, Zaman As Double
    
    Zaman = Timer

    Set S1 = Sheets("VERİ KAYNAĞI")
    Set S2 = Sheets("ANALİZ")
    Set Dizi = CreateObject("Scripting.Dictionary")

    S2.Range("D2:E55").ClearContents
    
    Son = S1.Cells(S1.Rows.Count, 1).End(3).Row
    If Son = 2 Then Son = 3
    
    Veri = S1.Range("A2:E" & Son).Value
    
    ReDim Liste(1 To UBound(Veri) * 3, 1 To 2)
    
    For Y = 1 To 3
        For X = LBound(Veri) To UBound(Veri)
            If Not Dizi.Exists(Veri(X, Y)) Then
                Say = Say + 1
                Dizi.Add Veri(X, Y), Say
                Liste(Say, 1) = Veri(X, 4)
                Liste(Say, 2) = Veri(X, 5)
            Else
                Liste(Dizi.Item(Veri(X, Y)), 1) = Liste(Dizi.Item(Veri(X, Y)), 1) + Veri(X, 4)
                Liste(Dizi.Item(Veri(X, Y)), 2) = Liste(Dizi.Item(Veri(X, Y)), 2) + Veri(X, 5)
            End If
        Next
    Next
    
    Veri = S2.Range("A2:B55").Value
    
    Say = 0
    
    ReDim Toplamlar(1 To UBound(Veri), 1 To 2)
        
    For X = LBound(Veri) To UBound(Veri)
        Say = Say + 1
        If Veri(X, 2) = "" Then
            Toplamlar(Say, 1) = ""
            Toplamlar(Say, 2) = ""
        Else
            If Veri(X, 1) = "" Then
                Toplamlar(Say, 1) = 0
                Toplamlar(Say, 2) = 0
            Else
                ReDim Formul_A(1 To Len(Veri(X, 1)))
                ReDim Formul_B(1 To Len(Veri(X, 1)))
                Karakter_Say = 0
                
                For Y = 1 To Len(Veri(X, 1))
                    If IsNumeric(Mid(Veri(X, 1), Y, 1)) Then
                        If Hesap_Kodu = 0 Then
                            Hesap_Kodu = Mid(Veri(X, 1), Y, 1)
                        Else
                            Hesap_Kodu = Hesap_Kodu & Mid(Veri(X, 1), Y, 1)
                        End If
                        If Y = Len(Veri(X, 1)) Then
                            If Hesap_Kodu <> 0 Then
                                Karakter_Say = Karakter_Say + 1
                                If Dizi.Exists(Hesap_Kodu) Then
                                    Formul_A(Karakter_Say) = Liste(Dizi.Item(Hesap_Kodu), 1)
                                    Formul_B(Karakter_Say) = Liste(Dizi.Item(Hesap_Kodu), 2)
                                Else
                                    Formul_A(Karakter_Say) = 0
                                    Formul_B(Karakter_Say) = 0
                                End If
                                Hesap_Kodu = 0
                            End If
                        End If
                    Else
                        If Hesap_Kodu <> 0 Then
                            Karakter_Say = Karakter_Say + 1
                            If Dizi.Exists(Hesap_Kodu) Then
                                Formul_A(Karakter_Say) = Liste(Dizi.Item(Hesap_Kodu), 1)
                                Formul_B(Karakter_Say) = Liste(Dizi.Item(Hesap_Kodu), 2)
                            Else
                                Formul_A(Karakter_Say) = 0
                                Formul_B(Karakter_Say) = 0
                            End If
                            Hesap_Kodu = 0
                        End If
                        Karakter_Say = Karakter_Say + 1
                        Formul_A(Karakter_Say) = Mid(Veri(X, 1), Y, 1)
                        Formul_B(Karakter_Say) = Mid(Veri(X, 1), Y, 1)
                    End If
                Next
                Toplamlar(Say, 1) = Evaluate(Trim(Replace(Replace(Join(Formul_A), ",", "."), " ", "")))
                Toplamlar(Say, 2) = Evaluate(Trim(Replace(Replace(Join(Formul_B), ",", "."), " ", "")))
            End If
        End If
    Next
    
    If Say > 0 Then
        S2.Range("D2").Resize(Say, UBound(Toplamlar, 2)) = Toplamlar
        S2.Columns.AutoFit
        S2.Select
    End If
    
    Set S1 = Nothing
    Set S2 = Nothing
    Set Dizi = Nothing
    
    MsgBox "Analiz işlemi tamamlanmıştır." & Chr(10) & Chr(10) & _
           "İşlem süresi ; " & Format(Timer - Zaman, "0.00") & " Saniye", vbInformation
End Sub