Farklı Sayfalarda Farklı miktardaki verileri birleştirme

[bestercan]

Merhaba;
İçinden Çıkamadığım sorum şöyle:
Sayfa1 de müşterilerin kalan ödemeleri var Sayfa2 de ise aynı kişilere ait arama notları var. Bunları sayfa3te birleştirmek istiyorum.
Dikkat edilmesi gereken Sayfa1 de 1012 nolu müşterinin tek ödemesi var ama Sayfa2 deki arama notunda 5 satır var
veya sayfa2de tek arama notu var ama sayfa1 de 4 taksidi var buna dikkat edilmeli. baz alınacak şey "sayfa1" ve müşteri noları

İstediğim tablo sayfa4 deki gibi. Ben bunu elle girdim ama formülle ya da makroyla yapmayı maalesef bilmiyorum.

Yardımcı olacak üstadlara şimdiden teşekkür ederim. Olursa çok işime yarayacak bir çalışma olacak.

 

[Ömer]

Merhaba,

Bu şekilde deneyin.

Sub Duzenle()
 
    Dim i As Long, c As Range, kol As Long
    Dim Adr As Variant, S1 As Worksheet, S2 As Worksheet
 
    Set S1 = Sheets("Sayfa1")
    Set S2 = Sheets("Sayfa2")
 
    Application.ScreenUpdating = False
    Sheets("Sayfa3").Select
 
    Cells.Clear
    S1.Cells.Copy Range("A1")
    S2.Range("A1:G1").Copy Range("I1")
 
    For i = Cells(Rows.Count, "A").End(xlUp).Row To 2 Step -1
        kol = 0
        With S2.Range("A:A")
          Set c = .Find(Cells(i, "A"), , xlValues, xlWhole)
            If Not c Is Nothing Then
              Adr = c.Address
                Do
                    S2.Range("A" & c.Row, "G" & c.Row).Copy Range("I" & i + kol)
                    kol = kol + 1
                    Rows(i + kol).Insert Shift:=xlDown
                  Set c = .FindNext(c)
                Loop While Not c Is Nothing And c.Address <> Adr
            End If
        End With
    Next i
 
    Cells.EntireColumn.AutoFit
    Application.ScreenUpdating = True
 
 End Sub

.

 

[bestercan]

Merhaba.
Ömer hocam ilgin için teşekkür ederim. Makroyu çalıştırdım ama ufak bi pürüz çıktı. Anlatımımdan kaynaklanan bir eksiklikte olabilir.
Şöyle ki: 2 taksidi geçen birine ait arama notlarının tamamı geciken her taksidin karşısında çıkıyor. Örnek 1017 nolu müşteride görbilirsiniz. 1, 3 veya 4 taksidi gecikmiş olsa bile o kişiye ait tüm arama notlarının bir defa çıkması mümkünmü?

Evde office 2010 kullanıyorum. Bundan kaynaklanbilirmi? İşyerinde Office 2007 kullanıyorum.

 

[Ömer]

Bu şekilde deneyin. İstediğiniz bu mu?

Sub Duzenle()
 
    Dim i As Long, c As Range, kol As Long, sat As Long, d
    Dim Adr As Variant, S1 As Worksheet, S2 As Worksheet, deg
 
    Set S1 = Sheets("Sayfa1")
    Set S2 = Sheets("Sayfa2")
    Set d = CreateObject("Scripting.Dictionary")
    
    Application.ScreenUpdating = False
    Sheets("Sayfa3").Select
 
    Cells.Clear
    
    sat = 1
    For i = 1 To S1.Cells(Rows.Count, "A").End(xlUp).Row
        deg = S1.Cells(i, "A")
        If d.exists(deg) = False Then
            d.Add deg, Nothing
            S1.Range("A" & i, "H" & i).Copy Range("A" & sat)
            sat = sat + 1
        End If
    Next i
 
    S2.Range("A1:G1").Copy Range("I1")
 
    For i = Cells(Rows.Count, "A").End(xlUp).Row To 2 Step -1
        kol = 0
        With S2.Range("A:A")
          Set c = .Find(Cells(i, "A"), , xlValues, xlWhole)
            If Not c Is Nothing Then
              Adr = c.Address
                Do
                    S2.Range("A" & c.Row, "G" & c.Row).Copy _
                        Range("I" & i + kol)
                    kol = kol + 1
                    Rows(i + kol).Insert Shift:=xlDown
                  Set c = .FindNext(c)
                Loop While Not c Is Nothing And c.Address <> Adr
            End If
        End With
    Next i
 
    Cells.EntireColumn.AutoFit
    Application.ScreenUpdating = True
 
 End Sub

.

 

[bestercan]

Ömer hocam amacım iki sayfayı yan yana birleştirmek karşılığı olmayan satırlar boş kalabilir. Sayfa4te örneği elle yaptım. Bunun gibi yapmaya çalışıyorum.

 

[bestercan]

Hocam yani sayfa1 de kaçtane borcu gözükürse gözüksün önemli değil. önemli olan arama notlarının yan tarafta birdefa çıkması. mesela sayfa1 de müşterinin 2 taksidi geçmişse her taksidin karşısında arama notunun çıkması gerekmiyor.

 

[Ömer]

Kusura bakmayın, işlerimin yoğunlu nedeniyle geri dönüşüm geç oldu.

Bu şekilde deneyin.

Sub Duzenle()
 
    Dim i As Long, j As Long, k As Long, Esk As Long
    Dim c As Range, Adr As String
    Dim S1 As Worksheet, S2 As Worksheet
    
    Set S1 = Sheets("Sayfa1")
    Set S2 = Sheets("Sayfa2")
    Application.ScreenUpdating = False
    
    Sheets("Sayfa3").Select
    Cells.Clear
    
    i = S1.Cells(Rows.Count, "A").End(xlUp).Row
    S1.Range("A2:H" & i).Sort S1.Range("A2")
    i = S2.Cells(Rows.Count, "A").End(xlUp).Row
    S2.Range("A2:G" & i).Sort S2.Range("A2")
    
    S1.Range("A1:H1").Copy Range("A1")
    S2.Range("A1:G1").Copy Range("I1")
        
    For i = 2 To S1.Cells(Rows.Count, "A").End(xlUp).Row
        If Not S1.Cells(i, "A") = Esk Then
            j = Cells(Rows.Count, "I").End(xlUp).Row + 1
            S1.Range("A" & i & ":H" & i).Copy Cells(j, "A")
            Esk = S1.Cells(i, "A")
            k = j
            With S2.Range("A:A")
                Set c = .Find(S1.Cells(i, "A"), LookIn:=xlValues, LookAt:=xlWhole)
                If Not c Is Nothing Then
                    Adr = c.Address
                    Do
                        S2.Range("A" & c.Row & ":G" & c.Row).Copy Cells(k, "I")
                        Set c = .FindNext(c)
                        k = k + 1
                    Loop While Not c Is Nothing And c.Address <> Adr
                End If
            End With
        Else
            j = Cells(Rows.Count, "A").End(xlUp).Row + 1
            S1.Range("A" & i & ":H" & i).Copy Cells(j, "A")
        End If
    Next i
    
    Application.ScreenUpdating = True
 
End Sub

.

 

[bestercan]

Ömer hocam Çok teşekkür ederim. Beni büyük bi yükten kurtardınız