kriterleri aynı karşılıkları farklı verileri beliri sıraya göre aktarmak

[numan şamil]

Merhaba arkadaşlar
Benim sorunun Sayfa1 "A"sutunundaki verileri Sayfa2 deki "A" sütununda arayarak karşısındaki( B ) sütunundaki verileri Sayfa1 deki "B" sütununda karşısına yazdırmak
Burdaki sorun veri sıraları değişken olup aynı kriterde birkaç tane olması
verilerin nasıl gelmesi gerektiği ekli dosyada manuel olarak yazılıp anlatılmıştır
Buna göre makro nasıl olur?

 

[Murat OSMA]

Şu kodları deneyin;

Sub Aynı_Olanları_Birleştir()
    Dim Rky As Range, a As Integer
    Columns(2).ClearContents
    For a = 3 To Range("A65536").End(3).Row
    Set Rky = Sayfa2.Columns(1).Find(Cells(a, 1), , , 1)
        If Not Rky Is Nothing Then
            murat = Rky.Address
            Do
                Set Rky = Sayfa2.Columns(1).FindNext(Rky)
                Cells(a, 2) = Rky.Offset(0, 1).Value
            Loop While Not Rky Is Nothing And murat <> Rky.Address
        End If
    Next a
    a = Empty: Set Rky = Nothing
End Sub

 

[numan şamil]

Şu kodları deneyin;

Sub Aynı_Olanları_Birleştir()
    Dim Rky As Range, a As Integer
    Columns(2).ClearContents
    For a = 3 To Range("A65536").End(3).Row
    Set Rky = Sayfa2.Columns(1).Find(Cells(a, 1), , , 1)
        If Not Rky Is Nothing Then
            murat = Rky.Address
            Do
                Set Rky = Sayfa2.Columns(1).FindNext(Rky)
                Cells(a, 2) = Rky.Offset(0, 1).Value
            Loop While Not Rky Is Nothing And murat <> Rky.Address
        End If
    Next a
    a = Empty: Set Rky = Nothing
End Sub

Merhaba Murat bey
Malesef kodlarınız istediğimi yapmıyor
Ekli dosyayı inceleyebilirmisiniz kodlarınızın uygulanmış hali
kırmızı ile boyanmış veriler yanlış gelmiş

 

[numan şamil]

Arkadaşlar konu güncel

 

[Murat OSMA]

Şu kodları deneyiniz;

Sub Aynı_Olanları_Birleştir()
    Dim Rky As Range, i As Integer
    [b3].Select
5    For Each Rky In Sayfa2.Range("A3:A16")
        If ActiveCell.Offset(0, -1).Value = Rky.Value Then
            ActiveCell.Value = Rky.Offset(0, 1).Value
            While ActiveCell.Value <> ""
                ActiveCell.Offset(2, 0).Select
                Rky.Resize(, 2).ClearContents
                GoTo 5
            Wend
        End If
        For i = 3 To Range("A65536").End(3).Row
            If Cells(i, 2) = "" And Cells(i, 1) = Rky.Value Then
                Cells(i, 2) = Rky.Offset(0, 1).Value
                Rky.Resize(, 2).ClearContents
            End If
        Next i
    Next Rky
    i = Empty: Set Rky = Nothing
End Sub

 

[numan şamil]

Merhaba murat bey
ilk denemede verileri aktardı
Yalnız verileri silip ("b" sütunundaki)
Tekrar aktar dediğimizde aktarmıyor

 

[Murat OSMA]

Önceki mesajdan alıntı yapmanıza lüzum yok, öncelikle onu silerseniz sevinirim.

Ikinci denediğizde aktarmiyor çünkü aktarirken sayfa2'deki verileri silmesini istedim. Sayfa2'de veri olmayınca da aktarmiyor.
Çözüm olarak bu yolu seçtim, uygun değilse yarın kodlari düzenlerim.

 

[Murat OSMA]

Şu kodları deneyiniz;

DefStr S: DefInt I: DefObj C, R
Sub Aynı_Olanlar()
    Set con = CreateObject("adodb.connection")
    Set rs = CreateObject("adodb.recordset")
    On Error Resume Next: Application.ScreenUpdating = False
    con.Open "provider=microsoft.ace.oledb.12.0;data source=" & _
    ThisWorkbook.FullName & ";Extended properties=""Excel 12.0;hdr=no"""
    Range("B3:C1000").ClearContents: Columns("A:B").Interior.ColorIndex = 0
    For i = 3 To Range("A65536").End(3).Row
        sorgu = "select f2 from [sayfa2$] where f1=" & _
        Cells(i, "A") & " group by f2 HAVING COUNT(f1)>=1"
        rs.Open sorgu, con, 1, 1: Cells(i, 2).CopyFromRecordset rs
    If WorksheetFunction.CountIf(Range("A3:A" & i), Cells(i, 1)) >= 1 Then _
        Cells(i, 1).Resize(, 2).Interior.ColorIndex = i + 30
    If rs.RecordCount > 1 Then
        son = Range("B65536").End(3).Row
    Range("B" & son - rs.RecordCount + 2 & ":B" & son).Cut Cells(son - 2, 3)
        Range("$C$3:$C$1000").RemoveDuplicates Columns:=1, Header:=xlNo
    If WorksheetFunction.CountIf(Range("B3:B" & i), Cells(i, 2)) > 1 Then
            Cells(i, 2).ClearContents
            If Cells(i, 2) = "" Then
                Cells(3, 3).Cut Cells(i, 2)
                Range("C3:C" & son).SpecialCells(4).Delete xlUp
            End If
        End If
    End If
    rs.Close: Next i: con.Close: Columns(3).ClearContents
    Application.ScreenUpdating = True: Set con = Nothing: Set rs = Nothing
    sorgu = "": i = Empty: son = Empty
End Sub

Dosyayı da ekliyorum.

 

[numan şamil]

Merhaba Murat bey
Üzerinde çalışarak ekli dosyadaki gibi
Şimdilik bir çözüm buldum Ancak
Verilerde mükerrer sayısı fazla olursa ne olur
bilmiyorum ekli dosyayı inceleyip yorum yaparsanız
veya değişmesi gereken yerler varsa belirtirseniz sevinirim

 

[Murat OSMA]

Merhaba Numan Bey,

5 nolu mesajım tam istediğiniz gibi aslında. Sadece verileri sildiriyorum.
Sildirmeyip başka bir alana kopyaladıktan sonra tekrar aynı alana aldırırsak sorun kalmaz.

8 nolu mesajımdaki kodlar istediğinizi karşılamadı mı ?

Ekediğiniz dosya da referans alınan başka hücreler var, çözüm olabilir ama buna gerek.

 

[numan şamil]

Merhaba Murat Bey
5 nolu mesajınızdaki kodları
kodları dediğiniz gibi verileri Sildirmeyip başka bir alana kopyaladıktan sonra tekrar aynı alana alacak şekilde revize edebilirmisiniz

 

[Murat OSMA]

Numan Bey, bu şekilde kullanabilirsiniz;

Sub Aynı_Olanları_Birleştir()
    Dim Rky As Range, i As Integer, son As Integer
    With Sayfa2
        son = .Range("B65536").End(3).Row
        .Range("A3:B" & son).Copy .Range("D3")
    [b3].Select
5    For Each Rky In .Range("A3:A16")
        If ActiveCell.Offset(0, -1).Value = Rky.Value Then
            ActiveCell.Value = Rky.Offset(0, 1).Value
            While ActiveCell.Value <> ""
                ActiveCell.Offset(2, 0).Select
                Rky.Resize(, 2).ClearContents
                GoTo 5
            Wend
        End If
        For i = 3 To Range("A65536").End(3).Row
            If Cells(i, 2) = "" And Cells(i, 1) = Rky.Value Then
                Cells(i, 2) = Rky.Offset(0, 1).Value
                Rky.Resize(, 2).ClearContents
            End If
        Next i
    Next Rky
        .Range("D3:E" & .Rows.Count).Copy .Range("A3")
        .Columns("D:E").ClearContents
    End With
    i = Empty: son =  empty: Set Rky = Nothing
End Sub

 

[numan şamil]

Murat Bey teşekkür ederim

 

[Murat OSMA]

Rica ederim Numan Bey...