• DİKKAT

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

Satır birleştirme ve Toplama

H

hawking62

Katılım
9 Nisan 2015
Mesajlar
29
Excel Vers. ve Dili
2010
Herkese merhaba. Siz saygıdeğer arkadaşlarıma bir sorum olacak. Diyelim ki
A1 hücresinde bir değer, B1 hücresinde bir metin ve C1 hücresinde ise bir sayı var. Farz edelim A1,B1 ve C1 in aynısını A2'ye, B2'ye ve C2'ye yazdım. İstediğim şu, bu durumda A1=A2 olursa A2değerleri otomatik silsin 2 özdeş satırı birleştirdiği için D1'e 2 yazsın. Ve bir daha A2=A1olursa aynı işlemi tekrarlasın, D1' 3 yazsın. Ne kadar açıklayabildim bilmiyorum. Şayet bu mümkünse yardımlarınızı bekliyorum saygılarımla.

Örnek dosyam: http://s3.dosya.tc/server2/fam8l3/ornek2.xlsx.html
 
Son düzenleme:
Merhaba,

Çalıştığınız sayfanın kod bölümüne kopyalayın. Kodlar C sütununa veriyi girdikten sonra çalışır ve istediğiniz kontrolü yapar.

Kod: 
Private Sub Worksheet_Change(ByVal Target As Range)
    
    If Intersect(Target, Range("C:C")) Is Nothing Then Exit Sub

    Dim son As Long, c As Range

    With Target
        If .Count > 1 Then Exit Sub
        If .Row < 2 Then Exit Sub
        If .Value = "" Then Exit Sub
        son = .Row - 1
        Set c = Range("A1:A" & son).Find(Cells(.Row, "A"), , xlValues, xlWhole)
        If Not c Is Nothing Then
            If Cells(c.Row, "B") = Cells(.Row, "B") And _
                    Cells(c.Row, "C") = Cells(.Row, "C") Then
                Cells(c.Row, "C") = Cells(c.Row, "C") + Target
                Cells(c.Row, "D") = Cells(c.Row, "D") + 1
                Cells(.Row, "A").Resize(1, 3).ClearContents
            End If
        End If
    End With

End Sub

.
 
Emeğiniz için çok teşekkür ederim Sayın Ömer. Kodunuzu denedim gayet başarılı. Ancak istediğim C'leri değil A ve B sütununda özdeş veriler aynı olursa birleştirsin ve C'leri toplasın. Ayrıca ilk birleştirmede D 2 den başlamalı. Kodu buna göre düzeltebilir misiniz? Ben bu konuda henüz yolun başındayım o yüzden yardımlarınıza ihtiyacım var. Saygılarımla.
 
Ayrıca şimdi farkettim. Formüller sonucunda elde edilen verilerde ( mesela a, b ve c sütununda formüller olsun) kod işe yaramıyor.
 
Örnek dosya ekleyebilirseniz daha iyi olur!
 
Dosyam yok sayın orion1. İstediğim şey özetle şu A,B ve C sütunlarında özdeş veriler olduğunda o satırı tek satır olarak yazacak. Mesela A1=A2, B1=B2, C1=C2 olduğunda A2,B2 ve C2 hücrelerinde olan veriler otomatik silinecek. D1 hücresine ise 2 den başlayarak kaç defa birleştirme yaptıysa birer birer artırarak sayı yazacak. (2,3,4,5... gibi)
 
Verileri formül sonucu geliyorsa yapı değişebilir.

Küçük bir örnek dosya hazırlayıp istediğinizi dosya içerisinde detaylı açıklayıp, dosyanızı paylaşım sitelerinden birine ekleyip linki paylaşmanızı rica ederim.

http://s3.dosya.tc/

Gibi bir site.

.
 
hawking62' Alıntı:
Dosyam yok sayın orion1. İstediğim şey özetle şu A,B ve C sütunlarında özdeş veriler olduğunda o satırı tek satır olarak yazacak. Mesela A1=A2, B1=B2, C1=C2 olduğunda A2,B2 ve C2 hücrelerinde olan veriler otomatik silinecek. D1 hücresine ise 2 den başlayarak kaç defa birleştirme yaptıysa birer birer artırarak sayı yazacak. (2,3,4,5... gibi)
Genişletmek için tıkla ...

Merhaba

Dosyam yok diyorsunuz ama size yardımcı olanların gerek formülleri gerekse de kodlarını nerede kullanacaksınız.

Mutlaka bir dosyada kullanacaksınızdır eğer bir dosyada da kullanmıyacaksanız o zamanda soru yersiz fazladan sorulmuş gibi bir şey olur değilmi.
 
Kod: 
Private Sub Worksheet_Change(ByVal Target As Range)
    
    If Intersect(Target, Range("A:A")) Is Nothing Then Exit Sub

    Dim son As Long, c As Range

    With Target
        If .Count > 1 Then Exit Sub
        If .Row < 2 Then Exit Sub
        If .Value = "" Then Exit Sub
        son = .Row - 1
        Set c = Range("A1:A" & son).Find(Cells(.Row, "A"), , xlValues, xlWhole)
        If Not c Is Nothing Then
            If Cells(c.Row, "A") = Cells(.Row, "A") And _
                    Cells(c.Row, "A") = Cells(.Row, "A") Then
                Cells(c.Row, "A") = Cells(c.Row, "A")
                Cells(c.Row, "D") = Cells(c.Row, "D") + 1
                Cells(.Row, "A").Resize(1).ClearContents
                Range("A" & son + 1).Select
            End If
        End If
    End With

End Sub
Kendimce bir şeyler yaptım. Ancak ilk birleştirme 1'den başlıyor. 2'den başlamasını istiyorum sadece (İlk birleştirmede 2 sonrakilerde 3,4,5... birer artırarak yazmalı) Verdiğim kodu düzenlerseniz sevinirim. Saygılarımla...
 
Alternatif kod
Bu kod sayfa1 deki değerleri sayfa2 ye birleştiriyor.
kod komut düğmesi ile çalışır.

Kod: 
Sub Gruplandir()

ZBasla = TimeValue(Now)
zaman = Timer

Set s1 = Sheets("Sayfa1") ' veri sayfası
Set s2 = Sheets("Sayfa2") 'aktarılan sayfa

s2.Range("a2:e" & Rows.Count).Clear
son1 = s1.Cells(Rows.Count, "c").End(3).Row

ReDim ara1(son1): ReDim ara2(son1):

For j = 2 To son1
ara1(j) = s1.Cells(j, "a") & s1.Cells(j, "b") & s1.Cells(j, "b")
ara2(j) = 1
Next j

sat1 = 2

For r = 2 To son1
aranan1 = ara1(r)

sut4 = 0
If ara2(r) = 1 Then

For i = r To son1
If ara1(i) = aranan1 Then
sut4 = sut4 + 1
ara2(i) = 0
End If
Next i
s2.Cells(sat1, 1).Value = sat1 - 1
s2.Cells(sat1, 2).Value = s1.Cells(r, 1).Value
s2.Cells(sat1, 3).Value = s1.Cells(r, 2).Value
s2.Cells(sat1, 4).Value = s1.Cells(r, 3).Value
s2.Cells(sat1, 5).Value = sut4

sat1 = sat1 + 1

End If
Next r

zBitis = TimeValue(Now)

MsgBox "İşleminiz tamamlanmıştır." & Chr(10) & _
"İşlem süresi ; " & Format(Timer - zaman, "0.00") & Chr(10) & _
"Geçen Süre " & CDate(zBitis - ZBasla), vbInformation, " Sonuç Penceresi"

End Sub
 
Öncelikle ilginiz için teşekkür ederim sayın halit3. Ancak istediğim şeyi burada bir kere daha özetliyorum. Her şey tamam sadece D sütununda birleştirme sayısı ile ilgili bir sorunum var. Onu da kod yazmayı iyi bilen arkadaşlar hiç şüphe yok ki kolayca halledeceklerdir. Siz de inceleyip yardımcı olursanız sevinirim.
Örnek dosyam: http://s3.dosya.tc/server2/fam8l3/ornek2.xlsx.html

Kod: 
Private Sub Worksheet_Change(ByVal Target As Range)
    
    If Intersect(Target, Range("A:A")) Is Nothing Then Exit Sub

    Dim son As Long, c As Range

    With Target
        If .Count > 1 Then Exit Sub
        If .Row < 2 Then Exit Sub
        If .Value = "" Then Exit Sub
        son = .Row - 1
        Set c = Range("A1:A" & son).Find(Cells(.Row, "A"), , xlValues, xlWhole)
        If Not c Is Nothing Then
            If Cells(c.Row, "A") = Cells(.Row, "A") And _
                    Cells(c.Row, "A") = Cells(.Row, "A") Then
                Cells(c.Row, "A") = Cells(c.Row, "A")
                Cells(c.Row, "D") = Cells(c.Row, "D") + 1
                Cells(.Row, "A").Resize(1).ClearContents
                Range("A" & son + 1).Select
            End If
        End If
    End With

End Sub

Yukarıda paylaştığım dosyaya uyarlanmış kodun, D sütununda bulunan hücrelere her birleştirmede 1'den değil de 2'den başlayıp birer arttırmasını sağlayarak düzeltilmesini rica ediyorum. Kod A sütunundaki özdeş hücrelere göre çalışmaktadır. Saygılarımla...
 
Son düzenleme:
Emeğiniz için çok teşekkür ederim Sayın Ömer. Kodunuzu denedim gayet başarılı. Ancak istediğim C'leri değil A sütununda özdeş veriler aynı olursa birleştirsin . Ayrıca ilk birleştirmede D 2 den başlamalı. Kodu buna göre düzeltebilir misiniz? Ben bu konuda henüz yolun başındayım o yüzden yardımlarınıza ihtiyacım var. Saygılarımla.
 
Merhaba,

A sütununa veri girişinizde kodlar çalışır.

Kod: 
Private Sub Worksheet_Change(ByVal Target As Range)
    
    If Intersect(Target, Range("A:A")) Is Nothing Then Exit Sub

    Dim son As Long, c As Range

    With Target
        If .Count > 1 Then Exit Sub
        If .Row < 2 Then Exit Sub
        If .Value = "" Then Exit Sub
        son = .Row - 1
        Set c = Range("A1:A" & son).Find(Cells(.Row, "A"), , xlValues, xlWhole)
        If Not c Is Nothing Then
            Cells(c.Row, "D") = Cells(c.Row, "D") + 1
            Cells(.Row, "A").ClearContents
            Range("A" & son + 1).Select
        End If
    End With

End Sub

.
 
Cevap yazmak için giriş yap yada kayıt ol.
Geri
Üst