Ekstre düzenleme

[igultekin2000]

Merhaba;
banka ekstresi geldiği haliyle çok yer kaplıyor. Açıklama satırı yerine göre 4/5 satır olabiliyor. Tarih ve tutarlar ise tek satır. Çoklu satırı tek yapabilirsen çok güzel olacak. Ciddi kağıt israfına neden oluyor.
Örnek dosyayı ekliyorum, yardımcı olacak arkadaşlara şimdiden teşekkür edim.

 

[YUSUF44]

Aşağıdaki makroyu dener misiniz?

Sub ekstre()
son = WorksheetFunction.Max(Cells(Rows.Count, "A").End(3).Row, Cells(Rows.Count, "B").End(3).Row)
For i = 2 To son
    For j = i + 1 To son
        If Cells(j, "A").Borders(xlEdgeBottom).LineStyle <> xlNone Then
            Range(Cells(i, "A"), Cells(j, "A")).Merge
            Range(Cells(i, "D"), Cells(j, "D")).Merge
            Range(Cells(i, "C"), Cells(j, "C")).Merge
            Cells(i, "E") = WorksheetFunction.TextJoin(",", True, Range(Cells(i, "B"), Cells(j, "B")))
            i = j
            j = son
        End If
    Next
Next
For k = son - 1 To 2 Step -1
    If Cells(k, "E") = "" Then
        Rows(k).Delete
    Else
        Cells(k, "B") = Cells(k, "E")
        Cells(k, "E").ClearContents
    End If
Next
End Sub

 

[igultekin2000]

Modüle kopyaladım, olmadı satır hatası verdi.
çalışma sayfasını içine makroyu kopyaladım. tepkisi kaldı.

 

[YUSUF44]

Hücrelerden birinde hata ifadesi vardı. Onları düzeltip deneyin.

 

[igultekin2000]

Bazı şeyler denedim ama başarılı olamadım. İlk satırda A-C-D sütunların ilk işlemleri kapsayacak şekilde satır bazında birleştiriyor. E sütununda işlem yapmadan hata veriyor.

 

[wezyr]

resime göre yazıyorum 18 satırdaki Ad hatasını kaldırıp deneyin

 

[igultekin2000]

ilk bölümde tarih, işlem tutarı ve Güncel bakiye veri bulunan ilk satırda tekli değerli satırları birleştiriyor. B sütunundaki bilgileri E hücresine yazacak durumda hata veriyor.

 

[necati]

2010 versiyonunda "TextJoin" fonksiyonu başka türlü kullanılıyor olabilir!

 

[igultekin2000]

Veya excel formül olsa da işimi görebilirim. Biraz daha araştırayım.

 

[YUSUF44]

Ben kendi kullandığım Ofis 365'e göre yapmıştım. TEXTJOIN yani METİNBİRLEŞTİR formülü eski versiyonlarda çalışmayabilir.

Eski versiyonlar için farklı çözüm üretmek gerekir. Şu anda cepten baktığımdan ilgilenmiyorum maalesef.

 

[igultekin2000]

ilginize teşekkür ederim.

 

[Ziynettin]

Alternatif;

Sub test()
Dim s1 As Worksheet
Set s1 = Sheets("Table 1")
a = s1.Range("A1:E" & s1.Cells(Rows.Count, 2).End(3).Row).Value


Set dc = CreateObject("scripting.dictionary")

ReDim b(1 To UBound(a), 1 To 4)

    For i = 2 To UBound(a)
        If Cells(i, 4).Borders(xlEdgeTop).LineStyle <> xlNone Then
            say = say + 1
            a(i, 5) = say
        End If
        
        If a(i, 5) <> "" Then y = a(i, 5)
        a(i, 5) = y
            
        krt = CStr(a(i, 5))
    
        If Not IsEmpty(krt) And Not dc.exists(krt) Then
            dc(krt) = dc.Count + 1
            n = dc.Count
        Else
            n = dc(krt)
        End If
    
        If a(i, 1) <> "" Then b(n, 1) = a(i, 1)
        
        If IsError(a(i, 2)) = False Then
        If a(i, 2) <> "" Then b(n, 2) = b(n, 2) & " " & a(i, 2)
        End If
    
        If a(i, 3) <> "" Then
            p = InStrRev(a(i, 3), "TL") - 1
            If p <= 0 Then
                b(n, 3) = a(i, 3)
            Else
                b(n, 3) = Left(a(i, 3), p) * 1
            End If
        End If
          
        If a(i, 4) <> "" Then
            v = InStrRev(a(i, 4), "TL") - 1
            If v <= 0 Then
                b(n, 4) = a(i, 4)
            Else
                b(n, 4) = Left(a(i, 4), v) * 1
            End If
        End If
        
    Next i
    Application.ScreenUpdating = False
        s1.Range("A2:D" & Rows.Count).ClearContents
        s1.Range("A2:D" & Rows.Count).ClearFormats
        s1.[A2].Resize(n).NumberFormat = "dd.mm.yyyy"
        s1.[C2].Resize(n, 2).NumberFormat = "#,##0.00 TL"
        s1.[A2].Resize(n, 4).Value = b
        s1.[A2].Resize(n, 4).Borders.Color = xlThin
    Application.ScreenUpdating = True
MsgBox "İşlem tamam.", vbInformation
End Sub

 

[igultekin2000]

Merhaba;
Teşekkür ederim Ziynettin Bey. Makro sorunsuz çalışıyor. Her ay kabusa dönen işlemi sonunda çözüldü. Anlayamadığım; ortak noktası bulunmayan listede neyi baz alıp da makroyu yazabiliyorsunuz. Formda çok sık görüyorum, her üstadın kendine özgü çözüm yöntemi oluyor. Çok da güzel oluyor. İyi ki bu forum sitesini bulmuşuz.

 

[Trilenium]

Yıl olmuş 2022 bankacıların ekstre sunuşları halen daha taş devrini geçemiyor.

 

[YUSUF44]

Merhaba;
Teşekkür ederim Ziynettin Bey. Makro sorunsuz çalışıyor. Her ay kabusa dönen işlemi sonunda çözüldü. Anlayamadığım; ortak noktası bulunmayan listede neyi baz alıp da makroyu yazabiliyorsunuz. Formda çok sık görüyorum, her üstadın kendine özgü çözüm yöntemi oluyor. Çok da güzel oluyor. İyi ki bu forum sitesini bulmuşuz.

Ortak nokta var aslında.: son satırın alt kenarında çizgi var. Sayın Ziynettin de aynı şekilde kullanmış. Makroda "B sütunundaki alt kenar çizgiliyse onları bir grup olarak kabul et ve şu şu işlemleri yap" diyoruz.

 

[YUSUF44]

Sorun çözülmüş ama benim kodlarımı da eski sürümlerde aşağıdaki gibi kullanabilirsiniz:

Sub ekstre()
son = WorksheetFunction.Max(Cells(Rows.Count, "A").End(3).Row, Cells(Rows.Count, "B").End(3).Row)
For i = 2 To son
    For j = i To son
        If Cells(j, "A").Borders(xlEdgeBottom).LineStyle = xlNone Then
            If Cells(i, "E") = "" Then
                Cells(i, "E") = Cells(j, "B")
            Else
                Cells(i, "E") = Cells(i, "E") & ", " & Cells(j, "B")
            End If
        Else
            If Cells(i, "E") = "" Then
                Cells(i, "E") = Cells(j, "B")
            Else
                Cells(i, "E") = Cells(i, "E") & ", " & Cells(j, "B")
            End If
            Range(Cells(i, "A"), Cells(j, "A")).Merge
            Range(Cells(i, "D"), Cells(j, "D")).Merge
            Range(Cells(i, "C"), Cells(j, "C")).Merge
            i = j
            j = son
        End If
    Next
Next
For k = son To 2 Step -1
    If Cells(k, "E") = "" Then
        Rows(k).Delete
    Else
        Cells(k, "B") = Cells(k, "E")
        Cells(k, "E").ClearContents
    End If
Next
End Sub

 

[igultekin2000]

Teşekkür ederim, güncel kod sorunsuz çalıştı.
Anahtar olarak
If Cells(j, "A").Borders(xlEdgeBottom).LineStyle = xlNone Then
bu kod mu oluyor, listelemeyi güncellemek için.