• DİKKAT

    DOSYA İndirmek/Yüklemek için ÜCRETLİ ALTIN ÜYELİK Gereklidir!
    Altın Üyelik Hakkında Bilgi

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

I

incsoft

Katılım
18 Ağustos 2009
Mesajlar
752
Excel Vers. ve Dili
Office Ev ve İş 2021 - Türkçe
Arkadaşlar ekli dosyamda detaylı anlattım.

Teşekkürler..
 

Ekli dosyalar

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
 
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
Genişletmek için tıkla ...

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

240775
 
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
 
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
Genişletmek için tıkla ...

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

240781
 
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
 
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
Genişletmek için tıkla ...

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ı
 
Son düzenleme:
Çü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.
 
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.
 
Cevap yazmak için giriş yap yada kayıt ol.
Geri
Üst