Soru toplama macrosunda sıra numarasını da dikkate aldırma

incsoft · 11 Kasım 2022

Arkadaşlar ekli dosyamda detaylı anlattım.

Teşekkürler..

Necdet · 12 Kasım 2022

Merhaba,
Deneyip sonucu bildirin lütfen.

Kod:

Sub ToplamAL()

    Dim i As Long, _
        j As Long, _
        d As Variant
    
    Columns("H:H").Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
    Range("H1") = "TUTAR"
    Columns("I:I").Delete Shift:=xlToLeft
    
    d = Range("A2").Value
    j = 2
    For i = 2 To Cells(Rows.Count, "A").End(3).Row + 1
        If Not Cells(i, "A") = d Then
            Cells(j, "H") = "=SUM(D" & j & ":D" & i - 1 & ")"
            If Not j = i - 1 Then
                With Range("H" & j & ":H" & i - 1)
                    .HorizontalAlignment = xlRight
                    .VerticalAlignment = xlTop
                    .MergeCells = True
                End With
            End If
            j = i
            d = Cells(i, "a")
        End If
    Next i
    
End Sub

incsoft · 12 Kasım 2022

Necdet' Alıntı:

Merhaba,
Deneyip sonucu bildirin lütfen.

Kod:

Sub ToplamAL()

    Dim i As Long, _
        j As Long, _
        d As Variant
   
    Columns("H:H").Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
    Range("H1") = "TUTAR"
    Columns("I:I").Delete Shift:=xlToLeft
   
    d = Range("A2").Value
    j = 2
    For i = 2 To Cells(Rows.Count, "A").End(3).Row + 1
        If Not Cells(i, "A") = d Then
            Cells(j, "H") = "=SUM(D" & j & ":D" & i - 1 & ")"
            If Not j = i - 1 Then
                With Range("H" & j & ":H" & i - 1)
                    .HorizontalAlignment = xlRight
                    .VerticalAlignment = xlTop
                    .MergeCells = True
                End With
            End If
            j = i
            d = Cells(i, "a")
        End If
    Next i
   
End Sub

işlem görüyor hocam teşekkürler ancak form düzen ayarlarını bozmakta

Muzaffer Ali · 12 Kasım 2022

Merhaba.
Kodları revize ettim deneyiniz.

Kod:

Sub ToplamAL()

    Dim i As Long, _
        j As Long, _
        d As Variant
    Columns("H:H").Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
    Range("H1") = "TUTAR"
    Columns("I:I").Delete Shift:=xlToLeft
    
    d = Range("A2").Value
    j = 2
    For i = 2 To Cells(Rows.Count, "B").End(3).Row + 1
        If Not Cells(i, "A") = d Then
            Cells(j, "H") = "=SUM(D" & j & ":D" & i - 1 & ")"
            Cells(j, "H").HorizontalAlignment = xlCenter
            If Not j = i - 1 Then
                With Range("H" & j & ":H" & i - 1)
                    .HorizontalAlignment = xlCenter
                    .VerticalAlignment = xlCenter
                    .MergeCells = True
                End With
            End If
            j = i
            d = Cells(i, "a")
        End If
    Next i
End Sub

incsoft · 12 Kasım 2022

Muzaffer Ali' Alıntı:

Merhaba.
Kodları revize ettim deneyiniz.

Kod:

Sub ToplamAL()

    Dim i As Long, _
        j As Long, _
        d As Variant
    Columns("H:H").Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
    Range("H1") = "TUTAR"
    Columns("I:I").Delete Shift:=xlToLeft
   
    d = Range("A2").Value
    j = 2
    For i = 2 To Cells(Rows.Count, "B").End(3).Row + 1
        If Not Cells(i, "A") = d Then
            Cells(j, "H") = "=SUM(D" & j & ":D" & i - 1 & ")"
            Cells(j, "H").HorizontalAlignment = xlCenter
            If Not j = i - 1 Then
                With Range("H" & j & ":H" & i - 1)
                    .HorizontalAlignment = xlCenter
                    .VerticalAlignment = xlCenter
                    .MergeCells = True
                End With
            End If
            j = i
            d = Cells(i, "a")
        End If
    Next i
End Sub

Olmuş teşekkürler hocam desteğiniz için. Birde hücre yapılarını bozmasa çok daha iyi olurdu. Toplam alınan alanı aşağıdaki gibi bozuyor

Muzaffer Ali · 13 Kasım 2022

Deneyiniz.
B sütunundaki satır sayısına göre işlem yapılmaktadır.
Eğer tablonuzun altında B sütununda başka veriler varsa onları da dikkate alacağından farklı biçimlendirme sonucu ortaya çıkabilir.

Kod:

Sub ToplamAL()

    Dim i As Long, _
        j As Long, _
        d As Variant
    Application.ScreenUpdating = False
    Columns("H:H").Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
    Range("H1") = "TUTAR"
    Columns("I:I").Copy
    Range("H1").PasteSpecial xlPasteFormats
    Range("G1").Activate
    Columns("I:I").Delete Shift:=xlToLeft
    
    d = Range("A2").Value
    j = 2
    For i = 2 To Cells(Rows.Count, "B").End(3).Row + 1
        If Not Cells(i, "A") = d Then
            Cells(j, "H") = "=SUM(D" & j & ":D" & i - 1 & ")"
            Cells(j, "H").HorizontalAlignment = xlCenter
            If Not j = i - 1 Then
                With Range("H" & j & ":H" & i - 1)
                    .HorizontalAlignment = xlCenter
                    .VerticalAlignment = xlCenter
                    .MergeCells = True
                End With
            End If
            j = i
            d = Cells(i, "a")
        End If
    Next i
    Application.ScreenUpdating = True
End Su

incsoft · 13 Kasım 2022

Muzaffer Ali' Alıntı:

Deneyiniz.
B sütunundaki satır sayısına göre işlem yapılmaktadır.
Eğer tablonuzun altında B sütununda başka veriler varsa onları da dikkate alacağından farklı biçimlendirme sonucu ortaya çıkabilir.

Kod:

Sub ToplamAL()

    Dim i As Long, _
        j As Long, _
        d As Variant
    Application.ScreenUpdating = False
    Columns("H:H").Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
    Range("H1") = "TUTAR"
    Columns("I:I").Copy
    Range("H1").PasteSpecial xlPasteFormats
    Range("G1").Activate
    Columns("I:I").Delete Shift:=xlToLeft
  
    d = Range("A2").Value
    j = 2
    For i = 2 To Cells(Rows.Count, "B").End(3).Row + 1
        If Not Cells(i, "A") = d Then
            Cells(j, "H") = "=SUM(D" & j & ":D" & i - 1 & ")"
            Cells(j, "H").HorizontalAlignment = xlCenter
            If Not j = i - 1 Then
                With Range("H" & j & ":H" & i - 1)
                    .HorizontalAlignment = xlCenter
                    .VerticalAlignment = xlCenter
                    .MergeCells = True
                End With
            End If
            j = i
            d = Cells(i, "a")
        End If
    Next i
    Application.ScreenUpdating = True
End Su

Teşekkürler hocam ancak neden B sütununa göre işlem yapıyor? Orjinal formumda başka veri var.Önemli olan A sütunundaki numaralara göre işlem yapması. A sütunundaki numara farklılıklarına göre işlem yapmalı

Muzaffer Ali · 13 Kasım 2022

Çünkü örnek dosyanızda A16 ve A17 de değer varken B,C ve D 16,17. satırlarda veri yok.
Yani en son değer 15. satırda var.

incsoft · 13 Kasım 2022

Muzaffer Ali' Alıntı:
Çünkü örnek dosyanızda A16 ve A17 de değer varken B,C ve D 16,17. satırlarda veri yok.
Yani en son değer 15. satırda var.

o örnek dosya hocam. Bu mantıkda çalışıyor dosyam.

Muzaffer Ali · 13 Kasım 2022

Kodu çalıştırdığınızda, istediğiniz sonucu alamıyor musunuz?
Eğer istediğiniz sonucu alamıyorsanız orijinal dosyanızı ekleyin kontrol edelim.

incsoft · 15 Kasım 2022

Muzaffer Ali' Alıntı:
Kodu çalıştırdığınızda, istediğiniz sonucu alamıyor musunuz?
Eğer istediğiniz sonucu alamıyorsanız orijinal dosyanızı ekleyin kontrol edelim.

incsoft · 20 Kasım 2022

Muzaffer Ali' Alıntı:
Kodu çalıştırdığınızda, istediğiniz sonucu alamıyor musunuz?
Eğer istediğiniz sonucu alamıyorsanız orijinal dosyanızı ekleyin kontrol edelim.

Muzaffer bey yeniden bakabildinizmi acaba?

incsoft · 21 Kasım 2022

Muzaffer Ali' Alıntı:
Kodu çalıştırdığınızda, istediğiniz sonucu alamıyor musunuz?
Eğer istediğiniz sonucu alamıyorsanız orijinal dosyanızı ekleyin kontrol edelim.

Hocam sanırım olmadı bu sefer?

Soru toplama macrosunda sıra numarasını da dikkate aldırma

incsoft

Ekli dosyalar

Necdet

Moderatör

incsoft

Muzaffer Ali

Destek Ekibi

incsoft

Muzaffer Ali

Destek Ekibi

incsoft

Muzaffer Ali

Destek Ekibi

incsoft

Muzaffer Ali

Destek Ekibi

incsoft

Ekli dosyalar

incsoft

incsoft