hücre içindeki toplu bilgileri, farklı hücrelere yazdırma

[besen]

Merhaba hücre içindeki toplu bilgileri, farklı hücrelere yazdırmak için yardıma ihtiyacım var.

Örnek dosyada açıklama yer almakta.

Saygılarımla.

 

[Korhan Ayhan]

Deneyiniz.

Sub DEĞERLERİ_AYRIŞTIR()
    Range("D2:E" & Rows.Count).Clear
    Satır = 2
    
    For Each Hücre In Range("B2:B9")
        Veri = Split(Hücre.Formula, "+")
        For X = 0 To UBound(Veri)
            If InStr(1, Veri(X), "(") = 0 Then
                Cells(Satır, "D") = Hücre.Offset(0, -1)
                Cells(Satır, "E") = Replace(Veri(X), "=", "")
                Satır = Satır + 1
            End If
        Next
    Next
        
    Range("D1:E" & Satır - 1).Borders.LineStyle = 1
    Cells(Satır + 1, "D") = "TOPLAM"
    Cells(Satır + 1, "E") = "=SUM(E2:E" & Satır - 1 & ")"
    Range("D" & Satır + 1 & ":E" & Satır + 1).Borders.LineStyle = 1

    MsgBox "İşleminiz tamamlanmıştır.", vbInformation
End Sub

 

[Ömer BARAN]

Merhaba.

Alternatif olsun.
.

Sub AYRISTIR()
If Cells(Rows.Count, "D").End(3).Row > 1 Then Range("D2:E" & Rows.Count).ClearContents
For sat = 2 To [A2].End(xlDown).Row
    formul = Cells(sat, 2).Formula: adet = Len(formul) - Len(Replace(formul, "+", ""))
    ilk = 0
    If Len(formul) <> Len(Replace(formul, ")", "")) Then ilk = 1
        For ssat = ilk To adet
            yazsat = Cells(Rows.Count, "D").End(3).Row + 1
            Cells(yazsat, "D") = Cells(sat, 1)
            Cells(yazsat, "E") = Split(formul, "+")(ssat)
        Next
Next
    Cells(Cells(Rows.Count, "D").End(3).Row + 2, "D") = "TOPLAM"
    Cells(Cells(Rows.Count, "E").End(3).Row + 2, "E") = _
    WorksheetFunction.Sum(Range("E2:E" & Cells(Rows.Count, "E").End(3).Row))
MsgBox "İşlem tamamlandı.", vbInformation, "..::.. Ömer BARAN ..::.."
End Sub

 

[besen]

Ne güzel insanlarsınız. Çok teşekkürler.

Deneyiniz.

Sub DEĞERLERİ_AYRIŞTIR()
    Range("D2:E" & Rows.Count).Clear
    Satır = 2
    
    For Each Hücre In Range("B2:B9")
        Veri = Split(Hücre.Formula, "+")
        For X = 0 To UBound(Veri)
            If InStr(1, Veri(X), "(") = 0 Then
                Cells(Satır, "D") = Hücre.Offset(0, -1)
                Cells(Satır, "E") = Replace(Veri(X), "=", "")
                Satır = Satır + 1
            End If
        Next
    Next
        
    Range("D1:E" & Satır - 1).Borders.LineStyle = 1
    Cells(Satır + 1, "D") = "TOPLAM"
    Cells(Satır + 1, "E") = "=SUM(E2:E" & Satır - 1 & ")"
    Range("D" & Satır + 1 & ":E" & Satır + 1).Borders.LineStyle = 1

    MsgBox "İşleminiz tamamlanmıştır.", vbInformation
End Sub