Makro ile Hücre Birleştirme

[anilman]

Merhaba
Ekteki dosyada sayfa 1 de herhangi bir faturadaki kalemleri alt alta yazıp, sayfa 2 de Vergi no ve fatura numarasına göre tek satırda birleştirmesini sağlıyorum.
Yeni bir özellik katmak istiyorum, sayfa1 deki I Sütunundaki rakamla Q sütunundaki metini de sayfa2 deki yine I Sütununa (1AD,1AD,100KG) şeklinde almasını istiyorum.

Yardımınız için şimdiden teşekkürler

 

[anilman]

Yardım edebilecek biri?

 

[numan şamil]

Merhaba
Kodlarınızda ufak bir değişiklik yaptım dener misiniz

Sub fatura_Birlestir()
Dim S1 As Worksheet, S2 As Worksheet
Dim a(), b(), dc As Object, say As Long, i As Long, j As Byte
Set S1 = Sheets("Alt Alta")
Set S2 = Sheets("Birleştirilen")
Set dc = CreateObject("scripting.dictionary")
    a = S1.Range("B4:Q" & S1.Cells(Rows.Count, 5).End(3).Row).Value
    ReDim b(1 To UBound(a), 1 To UBound(a, 2))
        For i = 2 To UBound(a)
            krt = CStr(a(i, 2)) & "|" & CStr(a(i, 4)) & "|" & CStr(a(i, 5))
            If Not dc.exists(krt) And Not IsEmpty(krt) Then
                dc(krt) = dc.Count + 1
                say = dc.Count
                b(say, 1) = say
                For j = 1 To 6: b(say, j) = a(i, j): Next j
                b(say, 7) = a(i, 7)
                b(say, 8) = a(i, 8) & a(i, 16)
                For j = 9 To 15: b(say, j) = b(say, j) + a(i, j): Next j
                b(say, 15) = a(i, 15)
            Else
                say = dc(krt)
                b(say, 7) = b(say, 7) & "," & a(i, 7)
                b(say, 8) = b(say, 8) & "," & a(i, 8) & a(i, 16)
                For j = 9 To 15: b(say, j) = b(say, j) + a(i, j): Next j
            End If
        Next i
    If dc.Count > 0 Then
        Application.ScreenUpdating = 0
        S2.Range("B3:Q" & Rows.Count).ClearFormats
        S2.Range("B3:Q" & Rows.Count).ClearContents
            With S2.[B3].Resize(dc.Count, UBound(a, 2))
                .Borders.Weight = xlHairline
                .BorderAround , xlMedium
            End With
        S2.[C3].Resize(dc.Count).NumberFormat = "dd.mm.yyyy"
        S2.[j3].Resize(dc.Count, 6).NumberFormat = "#,##0.00"
        S2.[P3].Resize(dc.Count, 6).NumberFormat = "#,##0.00"
        S2.[G3].Resize(dc.Count).NumberFormat = "@"
        S2.[B3].Resize(dc.Count, UBound(a, 2)) = b
        Application.ScreenUpdating = 1
        MsgBox "Birleştirme Tamam.", vbInformation
        
    Else
        MsgBox "Liste Boş Olduğundan İşlem Yok", vbExclamation
    End If
End Sub

 

[anilman]

Oldu çok teşekkürler

 

[numan şamil]

iyi çalışmalar

 

[anilman]

Tekrar Merhaba
Ekteki dosyada C5 ten başlayıp C6,C7... veri girildikçe, B5,B6,B7... hücrelerine otomatik sayı atasın istiyorum. Yardımcı olur musunuz?

 

[ÖmerFaruk]

Formülle isterseniz B5 ye yazın ve aşağı sürükleyin
=EĞER(C5<>"";SATIR(A1);"")

Kodla yapayım derseniz, C5 den itibaren boşluk bırakmadan satırları doldurmak şartıyla

Private Sub Worksheet_Change(ByVal Target As Range)
If Intersect(Target, Range("C5:C9999")) Is Nothing Then Exit Sub
Range("B" & Target.Row) = Target.Row - 4
End Sub

 

[anilman]

Formülle isterseniz B5 ye yazın ve aşağı sürükleyin
=EĞER(C5<>"";SATIR(A1);"")

Kodla yapayım derseniz, C5 den itibaren boşluk bırakmadan satırları doldurmak şartıyla

Private Sub Worksheet_Change(ByVal Target As Range)
If Intersect(Target, Range("C5:C9999")) Is Nothing Then Exit Sub
Range("B" & Target.Row) = Target.Row - 4
End Sub

Kod kullanımında iken kopyala yapıştır yaptığımda otomatik gelmiyor. F2 yapıp hücre içine girdiğimde geliyor, bunu nasıl yapabiliriz?

 

[ÖmerFaruk]

Hangi koddan bahsediyorsunuz?
Sayfada farklı kodlarla bir işlem mi yapıyorsunuz?
Kopyala Yapıştır derken ten bir satırdan fazla veriyi mi bir an da mı yapıştırıyorsunuz?

Aşağıdaki şekilde deneyin. Umarım başka varyasyon gelmez.

Private Sub Worksheet_Change(ByVal Target As Range)
Dim Liste
    If Intersect(Target, Range("C5:C9999")) Is Nothing Then Exit Sub
    Son = Range("C" & Rows.Count).End(3).Row
    ReDim Liste(1 To Son, 1 To 1)
    For i = 5 To Son
        Liste(i - 4, 1) = i - 4
    Next i
    Range("B5").Resize(Son - 4, 1) = Liste
End Sub

 

[anilman]

Hangi koddan bahsediyorsunuz?
Sayfada farklı kodlarla bir işlem mi yapıyorsunuz?
Kopyala Yapıştır derken ten bir satırdan fazla veriyi mi bir an da mı yapıştırıyorsunuz?

Aşağıdaki şekilde deneyin. Umarım başka varyasyon gelmez.

Private Sub Worksheet_Change(ByVal Target As Range)
Dim Liste
    If Intersect(Target, Range("C5:C9999")) Is Nothing Then Exit Sub
    Son = Range("C" & Rows.Count).End(3).Row
    ReDim Liste(1 To Son, 1 To 1)
    For i = 5 To Son
        Liste(i - 4, 1) = i - 4
    Next i
    Range("B5").Resize(Son - 4, 1) = Liste
End Sub

Önceki vermiş olduğunuz kodu sayfaya yapıştırdım, evet birden fazla veriyi sayfaya yapıştırdığımda sayılar otomatik atmadı.
Ama son yazmış olduğunuz kodlar işe yaradı tam istediğim gibi veriyi yapıştırdığımda sayılar atandı. Teşekkürler...

 

[ÖmerFaruk]

Rica ederim.
Sonucu etkilemez belki ufak bir düzeltme yaptım

Private Sub Worksheet_Change(ByVal Target As Range)
Dim Liste
    If Intersect(Target, Range("C5:C9999")) Is Nothing Then Exit Sub
    Son = Range("C" & Rows.Count).End(3).Row - 4
    ReDim Liste(1 To Son, 1 To 1)
    For i = 1 To Son
        Liste(i , 1) = i
    Next i
    Range("B5").Resize(Son , 1) = Liste
End Sub

 

[anilman]

Tamamdır Sağ olun

 

[anilman]

Rica ederim.
Sonucu etkilemez belki ufak bir düzeltme yaptım

Private Sub Worksheet_Change(ByVal Target As Range)
Dim Liste
    If Intersect(Target, Range("C5:C9999")) Is Nothing Then Exit Sub
    Son = Range("C" & Rows.Count).End(3).Row - 4
    ReDim Liste(1 To Son, 1 To 1)
    For i = 1 To Son
        Liste(i , 1) = i
    Next i
    Range("B5").Resize(Son , 1) = Liste
End Sub

Kusura bakmayın bir hata ile karşılaştım, sayfa içini sildiğimde görseldeki hatayı veriyor.

 

[ÖmerFaruk]

Private Sub Worksheet_Change(ByVal Target As Range)
Dim Liste
    If Intersect(Target, Range("C5:C9999")) Is Nothing Then Exit Sub
    Son = Range("C" & Rows.Count).End(3).Row - 4
    Range("B4:B" & Rows.Count) = ""
    If Son < 1 Then Exit Sub
    ReDim Liste(1 To Son, 1 To 1)
    For i = 1 To Son
        Liste(i, 1) = i
    Next i
    Range("B5").Resize(Son, 1) = Liste
End Sub

 

[anilman]

Bu sefer tam oldu teşekkürler )