• DİKKAT

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

Ortak Değere Göre Birleştirme

O

omerfe

Katılım
16 Ekim 2009
Mesajlar
40
Excel Vers. ve Dili
2010 English
Merhaba,

Ekteki dosyada data sayfasında sistemden çektiğimiz fatura bilgileri mevcut. Sistemden gelen data'da aynı fatura içinde birkaç farklı ürün olduğunda bunu ayrı satırlarda listeliyor. Bu tip faturaları tek satırda birleştirmem gerekiyor. İstenen sayfasında birleştirilmiş hallerini de örnek olarak gösterdim. G sütununa göre aynı fatura numaralı (E sütunu) olanların J ve K sütunlarını toplatmak gerekiyor.

Aslında I sütunundaki miktar verilerini de virgülle ayrıştırarak birleştirmek gerekir ama zor olur diye bunu istemiyorum.

Yardımcı olan herkese teşekkürler.

Kolaylıklar.
 

Ekli dosyalar

Merhaba,

Bu şekilde deneyin.

Kod: 
Sub Duzenle()
 
    Dim d As Object, Sn As Worksheet
    Dim i As Long, j As Byte, deg, s, a1
 
    Set d = CreateObject("Scripting.Dictionary")
    Set Sn = Sheets("[COLOR="red"]İstenen[/COLOR]")
 
    Application.ScreenUpdating = False
    Sheets("[COLOR="Red"]Data[/COLOR]").Select

    For i = 2 To Cells(Rows.Count, "E").End(xlUp).Row
        deg = Cells(i, "E") & "|" & Cells(i, "G")
        If Not d.exists(deg) Then
            ReDim s(2 To 14)
            For j = 2 To 14
                s(j) = Cells(i, j)
            Next j
            d.Add deg, s
        Else
            s = d.Item(deg)
            For j = 10 To 11
                s(j) = s(j) + Cells(i, j)
            Next j
            d.Item(deg) = s
        End If
    Next i
    
    Sn.Select
    Cells.ClearContents
    
    a1 = d.items
    For i = 0 To d.Count - 1
        s = a1(i)
        For j = 2 To 14
            Cells(1 + i, j - 1) = s(j)
        Next j
    Next i
    
    Application.ScreenUpdating = True

End Sub


.
 
ömer hocam yardımınız için teşekkür ederim. sonuca rahatlıkla ulaşabildim. bir sonraki aşamada ekteki tabloya da buna benzer bir makro uygulamam gerekiyor. Bilgim olmadığı için ilerleyemedim.

bu tabloda öncekiyle aynı bilgileri içermekle birlikte bir sütun daha -"L" sütununu- toplatmam gerekiyor. yine ilk tablodaki gibi işaretleyerek tabloyu ekliyorum. bakma fırsatınız olursa sevinirim.
 

Ekli dosyalar

Bu şekilde deneyin.

Kod: 
Sub Duzenle()
 
    Dim d As Object, Sn As Worksheet
    Dim i As Long, j As Byte, deg, s, a1
 
    Set d = CreateObject("Scripting.Dictionary")
    Set Sn = Sheets("İstenen")
 
    Application.ScreenUpdating = False
    Sheets("Data").Select

    For i = 1 To Cells(Rows.Count, "E").End(xlUp).Row
        deg = Cells(i, "E") & "|" & Cells(i, "G")
        If Not d.exists(deg) Then
            ReDim s(2 To 17) 'başlangıç ve bitiş sütunu
            For j = 2 To 17
                s(j) = Cells(i, j)
            Next j
            d.Add deg, s
        Else
            s = d.Item(deg)
            For j = 10 To 12 'toplama girecek sütunlar
                s(j) = s(j) + Cells(i, j)
            Next j
            d.Item(deg) = s
        End If
    Next i
    
    Sn.Select
    Cells.ClearContents
    
    a1 = d.items
    For i = 0 To d.Count - 1
        s = a1(i)
        For j = 2 To 17
            Cells(1 + i, j - 1) = s(j)
        Next j
    Next i
    
    Application.ScreenUpdating = True

End Sub


.
 
Sn. ömer hocam, toplanacak sütunlar yan yana değil de farklı sütunlarda olsaydı, örnek dosyada 10. sütun ve 13 sutun ve 16 sütun toplanması gerekseydi, kodda nasıl bir değişiklik olurdu. Teşekkürler.
 
Merhaba,

Bu şekilde deneyin.

Kod: 
Sub Duzenle()
 
    Dim d As Object, Sn As Worksheet, tpl()
    Dim i As Long, j As Byte, deg, s, a1
 
    Set d = CreateObject("Scripting.Dictionary")
    Set Sn = Sheets("İstenen")
    [COLOR="Red"]tpl = Array(10, 13, 16)[/COLOR] 'toplama girecek sütunlar
 
    Application.ScreenUpdating = False
    Sheets("Data").Select

    For i = 1 To Cells(Rows.Count, "E").End(xlUp).Row
        deg = Cells(i, "E") & "|" & Cells(i, "G")
        If Not d.exists(deg) Then
            ReDim s(2 To 17) 'başlangıç ve bitiş sütunu
            For j = 2 To 17
                s(j) = Cells(i, j)
            Next j
            d.Add deg, s
        Else
            s = d.Item(deg)
            For j = 0 To UBound(tpl)
                s(tpl(j)) = s(tpl(j)) + Cells(i, tpl(j))
            Next j
            d.Item(deg) = s
        End If
    Next i
    
    Sn.Select
    Cells.ClearContents
    
    a1 = d.items
    For i = 0 To d.Count - 1
        s = a1(i)
        For j = 2 To 17
            Cells(1 + i, j - 1) = s(j)
        Next j
    Next i
    
    Application.ScreenUpdating = True

End Sub


.
 
omerfe' Alıntı:
Merhaba,

Ekteki dosyada data sayfasında sistemden çektiğimiz fatura bilgileri mevcut. Sistemden gelen data'da aynı fatura içinde birkaç farklı ürün olduğunda bunu ayrı satırlarda listeliyor. Bu tip faturaları tek satırda birleştirmem gerekiyor. İstenen sayfasında birleştirilmiş hallerini de örnek olarak gösterdim. G sütununa göre aynı fatura numaralı (E sütunu) olanların J ve K sütunlarını toplatmak gerekiyor.

Aslında I sütunundaki miktar verilerini de virgülle ayrıştırarak birleştirmek gerekir ama zor olur diye bunu istemiyorum.

Yardımcı olan herkese teşekkürler.

Kolaylıklar.
Genişletmek için tıkla ...

Data dosyasındaki H ve I sütunlarını da aralarına virgül koyarak birleştirmem gerekiyor. CF22015000001224 numaralı fatura için görünüm şöyle olmalı;
H sütunu: PANO MALZEMESİ,PANO MALZEMESİ
I sütunu: 23 ADET,1 ADET

Ömer Hocam ve yardımcı olabilecek üstadlardan yardım bekliyorum.

Teşekkürler.
 
cevap gelmediği için son bir kez öne almak istedim konuyu..
 
Aşağıdaki kodu deneyin.

Kod: 
Sub Duzenle()
 
    Dim d As Object, Sn As Worksheet, tpl()
    Dim i As Long, j As Byte, deg, s, a1
 
    Set d = CreateObject("Scripting.Dictionary")
    Set Sn = Sheets("İstenen")
    tpl = Array(10, 11, 12) 'toplama girecek sütunlar
 
    Application.ScreenUpdating = False
    Sheets("Data").Select

    For i = 1 To Cells(Rows.Count, "E").End(xlUp).Row
        deg = Cells(i, "E") & "|" & Cells(i, "G")
        If Not d.exists(deg) Then
            ReDim s(2 To 17) 'başlangıç ve bitiş sütunu
            For j = 2 To 17
                s(j) = Cells(i, j)
            Next j
            d.Add deg, s
        Else
            s = d.Item(deg)
            For j = 0 To UBound(tpl)
                s(tpl(j)) = s(tpl(j)) + Cells(i, tpl(j))
            Next j
            s(8) = s(8) & ", " & Cells(i, 8)
            s(9) = s(9) & ", " & Cells(i, 9)
            d.Item(deg) = s
        End If
    Next i
    
    Sn.Select
    Cells.ClearContents
        
    a1 = d.items
    For i = 0 To d.Count - 1
        s = a1(i)
        For j = 2 To 17
            Cells(1 + i, j - 1) = s(j)
        Next j
    Next i
    
    Cells.EntireColumn.AutoFit
    
    Application.ScreenUpdating = True

    MsgBox "İşleminiz tamamlanmıştır.", vbInformation
End Sub
 
Korhan hocam desteğiniz için teşekkürler.

Allah işinizi gücünüzü rast getirsin.
 
selamlar,

makronun aşağıda işaretlediğim bölümünde "run time error '13' type mismatch" hatası alıyorum. Neden olabilir acaba?

Cevaplarınız için teşekkürler.



Korhan Ayhan' Alıntı:
Aşağıdaki kodu deneyin.

Kod: 
Sub Duzenle()
 
    Dim d As Object, Sn As Worksheet, tpl()
    Dim i As Long, j As Byte, deg, s, a1
 
    Set d = CreateObject("Scripting.Dictionary")
    Set Sn = Sheets("İstenen")
    tpl = Array(10, 11, 12) 'toplama girecek sütunlar
 
    Application.ScreenUpdating = False
    Sheets("Data").Select

    For i = 1 To Cells(Rows.Count, "E").End(xlUp).Row
        deg = Cells(i, "E") & "|" & Cells(i, "G")
        If Not d.exists(deg) Then
            ReDim s(2 To 17) 'başlangıç ve bitiş sütunu
            For j = 2 To 17
                s(j) = Cells(i, j)
            Next j
            d.Add deg, s
        Else
            s = d.Item(deg)
            For j = 0 To UBound(tpl)
[B][COLOR="Red"]                s(tpl(j)) = s(tpl(j)) + Cells(i, tpl(j))[/COLOR][/B]
            Next j
            s(8) = s(8) & ", " & Cells(i, 8)
            s(9) = s(9) & ", " & Cells(i, 9)
            d.Item(deg) = s
        End If
    Next i
    
    Sn.Select
    Cells.ClearContents
        
    a1 = d.items
    For i = 0 To d.Count - 1
        s = a1(i)
        For j = 2 To 17
            Cells(1 + i, j - 1) = s(j)
        Next j
    Next i
    
    Cells.EntireColumn.AutoFit
    
    Application.ScreenUpdating = True

    MsgBox "İşleminiz tamamlanmıştır.", vbInformation
End Sub
Genişletmek için tıkla ...
 
Hatanın nedeni "k" sütununda değer bulunmayan hücrelerin olmasıymış. Bunları "0" olarak düzelttiğimde çalıştı.
 
Cevap yazmak için giriş yap yada kayıt ol.
Geri
Üst