çok satırlı veriyi tek satıra toplama

[ihaveanidea]

arkadaşlar elimde bir indirilecek kdv listesi var. faturada yer alan her malın cinsi adedi tutarı ve kdv si ayrı ayrı belirtilmiş. benim istediğim birden çok mal içeren faturaları tek satıra toplamak ve yine tek satır olan faturaları da aynı şekilde aktarmak. örnek bir dosya ekledim. yardımcı olursanız çok teşekkür ederim.

 

[dEdE]

Merhaba,
Dosyanız ektedir.

Sub Aktar()
Set S1 = Sheets("İNDİRİM")
Set S2 = Sheets("İVD İND.")

For i = 2 To S1.Range("A" & Rows.Count).End(3).Row
    If S1.Cells(i, 4).Value = S1.Cells(i + 1, 4).Value Then
        mal = mal & Cells(i, 6).Value & "-"
        mik = mik & Cells(i, 7).Value & "AD-"
        mat = mat + Cells(i, 8).Value
        kdv = kdv + Cells(i, 9).Value
    Else
        ss = S2.Range("A" & Rows.Count).End(3).Row + 1
        For j = 1 To 5
            S2.Cells(ss, j).Value = S1.Cells(i, j).Value
        Next
        S2.Cells(ss, 6).Value = mal & Cells(i, 6).Value
        S2.Cells(ss, 7).Value = mik & Cells(i, 7).Value & "AD"
        S2.Cells(ss, 8).Value = mat + Cells(i, 8).Value
        S2.Cells(ss, 9).Value = kdv + Cells(i, 9).Value
        mal = "": mik = "": mat = 0: kdv = 0
    End If
Next i
MsgBox "Aktarma Tamamlandı.", vbInformation, "dEdE " & Application.UserName & "'e Başarılar diler."
End Sub

 

[ihaveanidea]

teşekkürler

Allah razı olsun harika olmuş çok teşekkürler

 

[monelogg]

Merhabalar,

Sub Aktar()
Set S1 = Sheets("İNDİRİM")
Set S2 = Sheets("İVD İND.")

For i = 2 To S1.Range("A" & Rows.Count).End(3).Row
    If S1.Cells(i, 4).Value = S1.Cells(i + 1, 4).Value Then
        mal = mal & Cells(i, 6).Value & "-"
        mik = mik & Cells(i, 7).Value & "AD-"
        mat = mat + Cells(i, 8).Value
        kdv = kdv + Cells(i, 9).Value
    Else
[COLOR="Red"][B]        
        ss = S2.Range("A" & Rows.Count).End(3).Row + 1
        For j = 1 To 5
            S2.Cells(ss, j).Value = S1.Cells(i, j).Value
        Next
[/B][/COLOR]        S2.Cells(ss, 6).Value = mal & Cells(i, 6).Value
        S2.Cells(ss, 7).Value = mik & Cells(i, 7).Value & "AD"
        S2.Cells(ss, 8).Value = mat + Cells(i, 8).Value
        S2.Cells(ss, 9).Value = kdv + Cells(i, 9).Value
        mal = "": mik = "": mat = 0: kdv = 0
    End If
Next i
MsgBox "Aktarma Tamamlandı.", vbInformation, "dEdE " & Application.UserName & "'e Başarılar diler."
End Sub

işimi görebilecek bir kod olduğundan bu koda çalışıyordum fakat yukarıda gösterdiğim kodun çalışırken neler yaptığını bir türlü kavrayamadım. Bu kısmı açıklayabilirseniz çok memnun olurum.

 

[dEdE]

Merhaba,
ss = S2.Range("A" & Rows.Count).End(3).Row + 1 ifadesi verilerin aktarılacağı sayfadaki ilk boş satırı buluyor.

For ile başlayan döngü ise A-E sütunlarını aktarmak için kullanılıyor. Beş satır kod yazmak yerine döngü kullanıldı.
Şöyle de yazılabilirdi.
S2.Cells(ss, "A").Value = S1.Cells(i, "A").Value ve aynı şekilde A ifadesi B,C,D,E ile deiştirilerek 5 satır yazılabilirdi.

Siz yazınca farkına vardım. En ideal yazım şekli şöyle olmalıydı.

ss = S2.Range("A" & Rows.Count).End(3).Row + 1
S2.Range("A" & ss & ":E" & ss).Value = S1.Range("A" & i & ":E" & i).Value

Böylece 4 satır yerine 2 satırla işlem yapılabilirdi.

Hoşçakalın.

 

[monelogg]

Haklısınız, ayrıca bu kod daha da sade olmuş, çok çok teşekkür ediyorum, emeğinize sağlık.

 

[ihaveanidea]

MRB

merhaba,
dosyanız ektedir.

sub aktar()
set s1 = sheets("indirim")
set s2 = sheets("ivd ind.")

for i = 2 to s1.range("a" & rows.count).end(3).row
    ıf s1.cells(i, 4).value = s1.cells(i + 1, 4).value then
        mal = mal & cells(i, 6).value & "-"
        mik = mik & cells(i, 7).value & "ad-"
        mat = mat + cells(i, 8).value
        kdv = kdv + cells(i, 9).value
    else
        ss = s2.range("a" & rows.count).end(3).row + 1
        for j = 1 to 5
            s2.cells(ss, j).value = s1.cells(i, j).value
        next
        s2.cells(ss, 6).value = mal & cells(i, 6).value
        s2.cells(ss, 7).value = mik & cells(i, 7).value & "ad"
        s2.cells(ss, 8).value = mat + cells(i, 8).value
        s2.cells(ss, 9).value = kdv + cells(i, 9).value
        mal = "": Mik = "": Mat = 0: Kdv = 0
    end ıf
next i
msgbox "aktarma tamamlandı.", vbınformation, "dede " & application.username & "'e başarılar diler."
end sub

merhaba. çok satırlı veriyi tek satıra toplama için yukardaki kodu yazmıştınız. Ancak bu kod satırları firma ismine göre birleştiriyor benim sizden ricam fatura numarasının her değişimine göre birleştirecek şekle getirmeniz. Vaktiniz olduğunda bir bakabilir misiniz lütfen

 

[dEdE]

Merhaba,
Örnek dosyanızda Fatura No sütunu yok. C sütunundaki no sütunu Fatura no ise aşağıdaki satırda kırmızı ile işaretlediğim rakamı 3 olarak değştirmeniz yeterki olacaktır.

  If S1.Cells(i, [COLOR="Red"]4[/COLOR]).Value = S1.Cells(i + 1,[COLOR="red"] 4[/COLOR]).Value Then

Kodların doğru çalışması için birleştirmeye esas ölçütün(firma yada fatura no)sıralı olması ve birleştirme sırasında oluşacak sütun sayısının kullandığınız excel versiyonunun desteklediği sütun sayısını geçmemesi gerekir.