Veri karşılaştırma makrosu.

[Carpintero]

Merhaba arkadaşlar içinden çıkamadığım dosyamın
küçük bir örneğini ekledim. Üçlü döngü gerekiyor sanırım ve
ben bunu yapamıyorum. Konuya hakim değerli uzman arkadaşların
yardımlarını bekliyorum.
Teşekkür ederim.

İndir örnek

Dosyayı indir örnek

dosya.co

 

[cems]

Sayın Carpintero

Dosyanızda R2-R10 arasında hiç birşey yok . Ayrıca sütunlarda istanbul mustafa erik gibi tür uyuşmazlığı da var.Dosyanız sanırım hiç bir şey anlatmayacak kadar küçülmüş boş sütunda neyi döndürerek tür uyuşmasa da altalta eklemeyi düşünüyorsunuz ? Burada soruda da bir açıklama yok ve işinizi en iyi bilen sizsiniz, yardımcı olmak isteyen biz sadece anlamaya çalışırız

 

[Carpintero]

Özür dilerim. dosya da aralığı yanlış tarif etmişim.
bu yeni dosya

İndir örnek

Dosyayı indir örnek

dosya.co

 

[Carpintero]

Sayın cems alakanız için teşekkür ederim.

Açıklamada da değindiğim gibi
sarı zeminli alandaki verileri E sütununda aratacağız
aramayı yapar iken ise kriterimiz B sütunundaki veriler olacak.
Döngü veri aynı olduğu sürece devam edecek veri değiştiğinde sonlanacak.
Sizin bahsettiğiniz tür tutarsızlığının yani D sütununun çok bi ehemmiyeti yok.
Erik elma vs veriler makronun doğru çalıştığını teyit etmek için koydum.

 

[YUSUF44]

Aşağıdaki makroyu dener misiniz?

Sub karma()
son = Cells(Rows.Count, "B").End(3).Row
yeni = 2
For i = 3 To son
    adet = WorksheetFunction.CountIf(Range("B3:B" & son), Cells(i, "B"))
    For j = 1 To adet
        Range(Cells(yeni + 1, Cells(i + j - 1, "E") + 8), Cells(yeni + adet, Cells(i + j - 1, "E") + 8)) = Cells(i + j - 1, "D")
    Next
    yeni = yeni + adet
    i = i + adet - 1
Next
End Sub

 

[Carpintero]

Merhaba Yusuf Bey çok teşekkür ederim alakanız için.
Kodu örneğe üzerinde denedim birebir görevini yapıyor.

B7:E9 aralığındaki verileri B15 e kopyalayıp tekrar denediğim de
meydana çıkan datalar karışıyor siz bir kontrol edebilir misiniz lütfen.

 

[Ziynettin]

Alternatif,

"Dizi metodu"

Sub test()
son = Cells(Rows.Count, "B").End(3).Row
Set dc = CreateObject("scripting.dictionary")
Set dz = CreateObject("scripting.dictionary")
a = Range("B3:E" & son).Value
    For i = 1 To UBound(a)
        krt = a(i, 1) & "#" & a(i, 4)
        dc(krt) = a(i, 3)
        dz(a(i, 4)) = ""
    Next i
sut = Application.Max(dz.keys)
ReDim b(1 To UBound(a), 1 To sut)
    For i = 1 To UBound(a)
        For j = 1 To sut
            b(i, j) = dc(a(i, 1) & "#" & j)
        Next j
    Next i
[I3].Resize(UBound(a), sut) = b
MsgBox "İşlem bitti.", vbInformation
End Sub

 

[Carpintero]

Merhaba Sayın Ziynettin;
Kod harika çalışıyor. Teşekkür ederim ellerinize sağlık.
Aynı düzen içinde. D sütunundaki verileri değilde bu verilerin satır nolarını
yazdırmak istesek kod üzerinde nereyi ne şekilde değiştirmemiz gerekli acaba ?
Atıyorum istanbul yazan yerlere 5 gibi yada erik yazan yerlere 12 gibi

 

[Ziynettin]

Ne yapmak istediğinizi anlamadım. Örnek dosya ekleyiniz.

 

[Carpintero]

Örnek ekte sayın Ziynettin.
D sütunundaki verilerin yerine verinin satır nosunu aktaracağız.
Teşekkür ederim.

İndir zynt

Dosyayı indir zynt

dosya.co

 

[Ziynettin]

dc(krt) = a(i, 3) kod satırını dc(krt) = i + 2 olarak düzeltiniz.

 

[Carpintero]

Tekrardan teşekkür ederim sayın Ziynettin
Elinize sağlık.

 

[Carpintero]

Tekrardan Merhaba;
Sayın Ziynettin ustam.
Yeni bir örnek ekledim. Bir öncekinin benzeri bir kod istemekteyim.
Bunun için yardımcı olabilir iseniz müteşekkir olacağım.

İndir yeni örnek

Dosyayı indir yeni örnek

dosya.co

 

[YUSUF44]

Merhaba Yusuf Bey çok teşekkür ederim alakanız için.
Kodu örneğe üzerinde denedim birebir görevini yapıyor.

B7:E9 aralığındaki verileri B15 e kopyalayıp tekrar denediğim de
meydana çıkan datalar karışıyor siz bir kontrol edebilir misiniz lütfen.

Verdiğim kod tamamen örnek dosyanıza göreydi ve dosyanızda da verileriniz aynı kodlar arka arkaya gelecek şekildeydi. Kodun çalışma mantığı da bunun üzerine kurulu. Farklı yerlerdeki kodlar için makroyu bayağı değiştirmek gerekir ama nasıl yapılır mantığını kuramadım. Zaten sayın Ziynettin sorununuzu çözmüş.

 

[Carpintero]

Aynen bahsettiğiniz gibi oldu Yusuf Bey. Sağ olun eksik olmayın.
Sizin mesajın bir üstünde textlerle ilgili de bir dosyam var o da aynı mantıkla
çözülmesi gerekiyor o na bakma imkanınız olabilir mi acaba ?

 

[alicimri]

Dosyanıza baktım, olması gereken veriler arasında, 7 satırdaki İstanbul'a ait veri niye yok.

 

[Carpintero]

Merhaba Ali Bey
O satırı doldurmayı unutmuşum.
Sonradan farkına ben de vardım ama msg düzeltme opsiyonu kapalı
gözüküyor bende. Diğer türlü de başlık çok karıştı.
Yardımcı olma şansınız olabilir mi acaba ?

 

[alicimri]

Torun çizgi film seyredecekmiş, elimden PC alıyor. Geldiğim aşamanın kodu aşağıda. akşam bir çözüm bulurum diye düşünüyorum.

Sub a()
Range("G6:K" & Cells(Rows.Count, 3).End(3).Row).Select
For i = 1 To Selection.Count
If Cells(Selection(i).Row, "E") = Cells(4, Selection(i).Column) Then
Range(Selection(i).Address).Value = Selection(i).Row
End If
Next
End Sub

 

[Carpintero]

Bahtı açık olsun küçüğün
Elinize sağlık niyetiniz dahi çok önemli.
Sağ olun eksik olmayın Ali Bey.

 

[Ziynettin]

Tekrardan Merhaba;
Sayın Ziynettin ustam.
Yeni bir örnek ekledim. Bir öncekinin benzeri bir kod istemekteyim.
Bunun için yardımcı olabilir iseniz müteşekkir olacağım.

İndir yeni örnek

Dosyayı indir yeni örnek

dosya.co

Sub kod()
son = Cells(Rows.Count, "C").End(3).Row
Set dc = CreateObject("scripting.dictionary")
a = Range("C4:K" & son).Value
    For i = 3 To UBound(a)
        If Not IsEmpty(a(i, 3)) Then
            krt = a(i, 1) & "|" & a(i, 3) & "#" & a(i, 3)
            dc(krt) = i + 3
        End If
    Next i

ReDim b(1 To UBound(a) - 2, 1 To 5)
    For i = 3 To UBound(a)
    If Not IsEmpty(a(i, 3)) Then
        For j = 5 To UBound(a, 2)
            krt = a(i, 1) & "|" & a(1, j) & "#" & a(i, 3)
            If dc.exists(krt) Then
                b(i - 2, j - 4) = dc(krt)
            End If
        Next j
        End If
    Next i
[G6].Resize(UBound(a) - 2, 5) = b
MsgBox "İşlem bitti.", vbInformation
end sub