Soru Şarta Bağlı Kopyala/Yapıştır Hakkında.

Y

yesimgurol

Altın Üye
Katılım
8 Aralık 2011
Mesajlar
950
Excel Vers. ve Dili
Excel 2016,32bit
Altın Üyelik Bitiş Tarihi
18-11-2024
Merhabalar,
Ekte bulunan Örnek dosyam da 2 adet tablo mevcut, Tablo 2'de yer alan değerlere göre Tablo 1'de arama yapılıp Tablo 2'de belirtilen hücreye değerlerin yazılması hususunda yardıma ihtiyacım var:-(
 

Ekli dosyalar

ÖmerFaruk

ÖmerFaruk

Destek Ekibi
Destek Ekibi
Katılım
22 Ekim 2017
Mesajlar
4,779
Excel Vers. ve Dili
Microsoft 365 Tr-64
Merhaba
Soru 1
L sütunundakiler Tablo1 de 2 şer satıra sahip, I sütunundaki YANLIŞ olmayan ya da sayısal olan satırlardaki değerler mi gelecek?

Soru 2
Formülle sizin için daha kolay olmaz mı?
 
Y

yesimgurol

Altın Üye
Katılım
8 Aralık 2011
Mesajlar
950
Excel Vers. ve Dili
Excel 2016,32bit
Altın Üyelik Bitiş Tarihi
18-11-2024
ÖmerFaruk' Alıntı:
Merhaba
Soru 1
L sütunundakiler Tablo1 de 2 şer satıra sahip, I sütunundaki YANLIŞ olmayan ya da sayısal olan satırlardaki değerler mi gelecek?

Soru 2
Formülle sizin için daha kolay olmaz mı?
Genişletmek için tıkla ...
Merhaba Ömer bey,
Evet sayısal değerlerin gelmesi yeterlidir.
Formüller de aslında yanlışlıkla değiştirilebiliyor diye güvenemeyişimden kodlar aslında ilk tercihimdi.
 
Y

yesimgurol

Altın Üye
Katılım
8 Aralık 2011
Mesajlar
950
Excel Vers. ve Dili
Excel 2016,32bit
Altın Üyelik Bitiş Tarihi
18-11-2024
ÖmerFaruk

ÖmerFaruk

Destek Ekibi
Destek Ekibi
Katılım
22 Ekim 2017
Mesajlar
4,779
Excel Vers. ve Dili
Microsoft 365 Tr-64
Mevcut kodlarınıza benzer şekilde ilaveler yaptım

C++: 
Sub ozet()
    Dim d As Object, i As Long, deg, son As Long, deg2 As Double
    Dim d1 As Object, d2 As Object, d3 As Object, d4 As Object, d5 As Object
    Dim d6 As Object, d7 As Object, d8 As Object, d9 As Object, d10 As Object

    Set d = CreateObject("Scripting.Dictionary")
    Set d1 = CreateObject("Scripting.Dictionary")
    Set d2 = CreateObject("Scripting.Dictionary")
    Set d3 = CreateObject("Scripting.Dictionary")
    Set d4 = CreateObject("Scripting.Dictionary")
    Set d5 = CreateObject("Scripting.Dictionary")
    Set d6 = CreateObject("Scripting.Dictionary")
    Set d7 = CreateObject("Scripting.Dictionary")
    Set d8 = CreateObject("Scripting.Dictionary")
    Set d9 = CreateObject("Scripting.Dictionary")
    Set d10 = CreateObject("Scripting.Dictionary")
    
    son = Cells(Rows.Count, "B").End(xlUp).Row
    Application.ScreenUpdating = False
    For i = 1 To son
        deg = Cells(i, "B")
        If Not d.exists(deg) Then
            d.Add deg, Nothing
        End If
        If i < 3 Then GoTo Devam
        If Cells(i, "I") <> False Then
            deg2 = Cells(i, "I")
            Select Case Cells(i, "C")
          Case Cells(2, 13)
                    d1.Add deg2, Nothing
          Case Cells(2, 14)
                    d2.Add deg2, Nothing
          Case Cells(2, 15)
                    d3.Add deg2, Nothing
          Case Cells(2, 16)
                    d4.Add deg2, Nothing
          Case Cells(2, 17)
                    d5.Add deg2, Nothing
          Case Cells(2, 18)
                    d6.Add deg2, Nothing
          Case Cells(2, 19)
                    d7.Add deg2, Nothing
          Case Cells(2, 20)
                    d8.Add deg2, Nothing
          Case Cells(2, 21)
                    d9.Add deg2, Nothing
          Case Cells(2, 22)
                    d10.Add deg2, Nothing
            End Select
        End If
Devam:
    Next i
    Range("L:L").ClearContents
    xx = d1.Count
    Range("L1").Resize(d.Count) = Application.Transpose(d.keys)
    Range("M3").Resize(d1.Count) = Application.Transpose(d1.keys)
    Range("N3").Resize(d2.Count) = Application.Transpose(d2.keys)
    Range("O3").Resize(d3.Count) = Application.Transpose(d3.keys)
    Range("P3").Resize(d4.Count) = Application.Transpose(d4.keys)
    Range("Q3").Resize(d5.Count) = Application.Transpose(d5.keys)
    Range("R3").Resize(d6.Count) = Application.Transpose(d6.keys)
    Range("S3").Resize(d7.Count) = Application.Transpose(d7.keys)
    Range("T3").Resize(d8.Count) = Application.Transpose(d8.keys)
    Range("U3").Resize(d9.Count) = Application.Transpose(d9.keys)
    Range("V3").Resize(d10.Count) = Application.Transpose(d10.keys)
End Sub
 
Y

yesimgurol

Altın Üye
Katılım
8 Aralık 2011
Mesajlar
950
Excel Vers. ve Dili
Excel 2016,32bit
Altın Üyelik Bitiş Tarihi
18-11-2024
ÖmerFaruk' Alıntı:
Mevcut kodlarınıza benzer şekilde ilaveler yaptım

C++: 
Sub ozet()
    Dim d As Object, i As Long, deg, son As Long, deg2 As Double
    Dim d1 As Object, d2 As Object, d3 As Object, d4 As Object, d5 As Object
    Dim d6 As Object, d7 As Object, d8 As Object, d9 As Object, d10 As Object

    Set d = CreateObject("Scripting.Dictionary")
    Set d1 = CreateObject("Scripting.Dictionary")
    Set d2 = CreateObject("Scripting.Dictionary")
    Set d3 = CreateObject("Scripting.Dictionary")
    Set d4 = CreateObject("Scripting.Dictionary")
    Set d5 = CreateObject("Scripting.Dictionary")
    Set d6 = CreateObject("Scripting.Dictionary")
    Set d7 = CreateObject("Scripting.Dictionary")
    Set d8 = CreateObject("Scripting.Dictionary")
    Set d9 = CreateObject("Scripting.Dictionary")
    Set d10 = CreateObject("Scripting.Dictionary")
   
    son = Cells(Rows.Count, "B").End(xlUp).Row
    Application.ScreenUpdating = False
    For i = 1 To son
        deg = Cells(i, "B")
        If Not d.exists(deg) Then
            d.Add deg, Nothing
        End If
        If i < 3 Then GoTo Devam
        If Cells(i, "I") <> False Then
            deg2 = Cells(i, "I")
            Select Case Cells(i, "C")
          Case Cells(2, 13)
                    d1.Add deg2, Nothing
          Case Cells(2, 14)
                    d2.Add deg2, Nothing
          Case Cells(2, 15)
                    d3.Add deg2, Nothing
          Case Cells(2, 16)
                    d4.Add deg2, Nothing
          Case Cells(2, 17)
                    d5.Add deg2, Nothing
          Case Cells(2, 18)
                    d6.Add deg2, Nothing
          Case Cells(2, 19)
                    d7.Add deg2, Nothing
          Case Cells(2, 20)
                    d8.Add deg2, Nothing
          Case Cells(2, 21)
                    d9.Add deg2, Nothing
          Case Cells(2, 22)
                    d10.Add deg2, Nothing
            End Select
        End If
Devam:
    Next i
    Range("L:L").ClearContents
    xx = d1.Count
    Range("L1").Resize(d.Count) = Application.Transpose(d.keys)
    Range("M3").Resize(d1.Count) = Application.Transpose(d1.keys)
    Range("N3").Resize(d2.Count) = Application.Transpose(d2.keys)
    Range("O3").Resize(d3.Count) = Application.Transpose(d3.keys)
    Range("P3").Resize(d4.Count) = Application.Transpose(d4.keys)
    Range("Q3").Resize(d5.Count) = Application.Transpose(d5.keys)
    Range("R3").Resize(d6.Count) = Application.Transpose(d6.keys)
    Range("S3").Resize(d7.Count) = Application.Transpose(d7.keys)
    Range("T3").Resize(d8.Count) = Application.Transpose(d8.keys)
    Range("U3").Resize(d9.Count) = Application.Transpose(d9.keys)
    Range("V3").Resize(d10.Count) = Application.Transpose(d10.keys)
End Sub
Genişletmek için tıkla ...
Merhaba Ömer bey,
Harika olmuş emeğinize sağlık çok teşekkür ederim.
 
Y

yesimgurol

Altın Üye
Katılım
8 Aralık 2011
Mesajlar
950
Excel Vers. ve Dili
Excel 2016,32bit
Altın Üyelik Bitiş Tarihi
18-11-2024
ÖmerFaruk' Alıntı:
Mevcut kodlarınıza benzer şekilde ilaveler yaptım

C++: 
Sub ozet()
    Dim d As Object, i As Long, deg, son As Long, deg2 As Double
    Dim d1 As Object, d2 As Object, d3 As Object, d4 As Object, d5 As Object
    Dim d6 As Object, d7 As Object, d8 As Object, d9 As Object, d10 As Object

    Set d = CreateObject("Scripting.Dictionary")
    Set d1 = CreateObject("Scripting.Dictionary")
    Set d2 = CreateObject("Scripting.Dictionary")
    Set d3 = CreateObject("Scripting.Dictionary")
    Set d4 = CreateObject("Scripting.Dictionary")
    Set d5 = CreateObject("Scripting.Dictionary")
    Set d6 = CreateObject("Scripting.Dictionary")
    Set d7 = CreateObject("Scripting.Dictionary")
    Set d8 = CreateObject("Scripting.Dictionary")
    Set d9 = CreateObject("Scripting.Dictionary")
    Set d10 = CreateObject("Scripting.Dictionary")
   
    son = Cells(Rows.Count, "B").End(xlUp).Row
    Application.ScreenUpdating = False
    For i = 1 To son
        deg = Cells(i, "B")
        If Not d.exists(deg) Then
            d.Add deg, Nothing
        End If
        If i < 3 Then GoTo Devam
        If Cells(i, "I") <> False Then
            deg2 = Cells(i, "I")
            Select Case Cells(i, "C")
          Case Cells(2, 13)
                    d1.Add deg2, Nothing
          Case Cells(2, 14)
                    d2.Add deg2, Nothing
          Case Cells(2, 15)
                    d3.Add deg2, Nothing
          Case Cells(2, 16)
                    d4.Add deg2, Nothing
          Case Cells(2, 17)
                    d5.Add deg2, Nothing
          Case Cells(2, 18)
                    d6.Add deg2, Nothing
          Case Cells(2, 19)
                    d7.Add deg2, Nothing
          Case Cells(2, 20)
                    d8.Add deg2, Nothing
          Case Cells(2, 21)
                    d9.Add deg2, Nothing
          Case Cells(2, 22)
                    d10.Add deg2, Nothing
            End Select
        End If
Devam:
    Next i
    Range("L:L").ClearContents
    xx = d1.Count
    Range("L1").Resize(d.Count) = Application.Transpose(d.keys)
    Range("M3").Resize(d1.Count) = Application.Transpose(d1.keys)
    Range("N3").Resize(d2.Count) = Application.Transpose(d2.keys)
    Range("O3").Resize(d3.Count) = Application.Transpose(d3.keys)
    Range("P3").Resize(d4.Count) = Application.Transpose(d4.keys)
    Range("Q3").Resize(d5.Count) = Application.Transpose(d5.keys)
    Range("R3").Resize(d6.Count) = Application.Transpose(d6.keys)
    Range("S3").Resize(d7.Count) = Application.Transpose(d7.keys)
    Range("T3").Resize(d8.Count) = Application.Transpose(d8.keys)
    Range("U3").Resize(d9.Count) = Application.Transpose(d9.keys)
    Range("V3").Resize(d10.Count) = Application.Transpose(d10.keys)
End Sub
Genişletmek için tıkla ...
Ömer bey tekrar merhabalar,
Orijinal veriler üzerinde kullanmaya başladım oluşturmuş olduğunuz kodları gayet güzelde çalışıyor gerçekten istediğim şekilde. Yalnız şöyle bir sorunumuz var. Ekteki dosya üzerinde de anlatmaya çalıştım durumu. Kısaca bahsetmem gerekirse "I" sütununda değerler içinde sıfır değeri olduğunda aktarılacak kısma değer almıyor almaması sorun değil aslında hücreyi boş bıraksa o da yeter ama en kötü durumu yapıyor, sıfır olan değerin yerine bir alttakini alıp yapıştırıyor. Haliyle bu durumda da kayma oluyor:-(

Birde yine "I" sütununda #DEĞER olduğunda kod haliyle uyarı verip çalışmayı kesiyor.

Bu durumlar için düzenleme yapmak mümkün müdür?
 

Ekli dosyalar

ÖmerFaruk

ÖmerFaruk

Destek Ekibi
Destek Ekibi
Katılım
22 Ekim 2017
Mesajlar
4,779
Excel Vers. ve Dili
Microsoft 365 Tr-64
#DEĞER hatası varsa ne yapacak?
 
ÖmerFaruk

ÖmerFaruk

Destek Ekibi
Destek Ekibi
Katılım
22 Ekim 2017
Mesajlar
4,779
Excel Vers. ve Dili
Microsoft 365 Tr-64
En baştan Select Case satırana kadarki kodları aşağıdakiyle değiştirin.

Not : Edit ettim. Kullandıysanız yeniden deneyin.

C#: 
Sub ozet2()
    Dim d As Object, i As Long, deg, son As Long, deg2
    Dim d1 As Object, d2 As Object, d3 As Object, d4 As Object, d5 As Object
    Dim d6 As Object, d7 As Object, d8 As Object, d9 As Object, d10 As Object

    Set d = CreateObject("Scripting.Dictionary")
    Set d1 = CreateObject("Scripting.Dictionary")
    Set d2 = CreateObject("Scripting.Dictionary")
    Set d3 = CreateObject("Scripting.Dictionary")
    Set d4 = CreateObject("Scripting.Dictionary")
    Set d5 = CreateObject("Scripting.Dictionary")
    Set d6 = CreateObject("Scripting.Dictionary")
    Set d7 = CreateObject("Scripting.Dictionary")
    Set d8 = CreateObject("Scripting.Dictionary")
    Set d9 = CreateObject("Scripting.Dictionary")
    Set d10 = CreateObject("Scripting.Dictionary")
   
    son = Cells(Rows.Count, "B").End(xlUp).Row
    Application.ScreenUpdating = False
    For i = 1 To son
        deg = Cells(i, "B")
        If Not d.exists(deg) Then
            d.Add deg, Nothing
        End If
        If i < 3 Then GoTo Devam
        If IsError(Cells(i, "I")) Then deg2 = "HATA": GoTo Atla1
        If Len(Cells(i, "I")) = 5 And Cells(i, "I") = 0 Then GoTo Devam
            deg2 = Cells(i, "I")
Atla1:
 
Y

yesimgurol

Altın Üye
Katılım
8 Aralık 2011
Mesajlar
950
Excel Vers. ve Dili
Excel 2016,32bit
Altın Üyelik Bitiş Tarihi
18-11-2024
Ömer bey ,
"End Select" altındaki "End If" kısmında uyarı veriyor.
 
ÖmerFaruk

ÖmerFaruk

Destek Ekibi
Destek Ekibi
Katılım
22 Ekim 2017
Mesajlar
4,779
Excel Vers. ve Dili
Microsoft 365 Tr-64
Doğru ben atlamışım. Aşağıda kodun komplesi var.

C++: 
Sub ozet2()
    Dim d As Object, i As Long, deg, son As Long, deg2
    Dim d1 As Object, d2 As Object, d3 As Object, d4 As Object, d5 As Object
    Dim d6 As Object, d7 As Object, d8 As Object, d9 As Object, d10 As Object

    Set d = CreateObject("Scripting.Dictionary")
    Set d1 = CreateObject("Scripting.Dictionary")
    Set d2 = CreateObject("Scripting.Dictionary")
    Set d3 = CreateObject("Scripting.Dictionary")
    Set d4 = CreateObject("Scripting.Dictionary")
    Set d5 = CreateObject("Scripting.Dictionary")
    Set d6 = CreateObject("Scripting.Dictionary")
    Set d7 = CreateObject("Scripting.Dictionary")
    Set d8 = CreateObject("Scripting.Dictionary")
    Set d9 = CreateObject("Scripting.Dictionary")
    Set d10 = CreateObject("Scripting.Dictionary")
    
    son = Cells(Rows.Count, "B").End(xlUp).Row
    Application.ScreenUpdating = False
    For i = 1 To son
        deg = Cells(i, "B")
        If Not d.exists(deg) Then
            d.Add deg, Nothing
        End If
        If i < 3 Then GoTo Devam
        If IsError(Cells(i, "I")) Then deg2 = "HATA": GoTo Atla1
        On Error Resume Next
        If Len(Cells(i, "I")) = 5 And Cells(i, "I") = 0 Then GoTo Devam
            deg2 = Cells(i, "I")
Atla1:
            Select Case Cells(i, "C")
            Case Cells(2, 13)
                d1.Add deg2, Nothing
            Case Cells(2, 14)
                d2.Add deg2, Nothing
            Case Cells(2, 15)
                d3.Add deg2, Nothing
            Case Cells(2, 16)
                d4.Add deg2, Nothing
            Case Cells(2, 17)
                d5.Add deg2, Nothing
            Case Cells(2, 18)
                d6.Add deg2, Nothing
            Case Cells(2, 19)
                d7.Add deg2, Nothing
            Case Cells(2, 20)
                d8.Add deg2, Nothing
            Case Cells(2, 21)
                d9.Add deg2, Nothing
            Case Cells(2, 22)
                d10.Add deg2, Nothing
            End Select
Devam:
    Next i
    Range("L:L").ClearContents
    Range("L1").Resize(d.Count) = Application.Transpose(d.keys)
    Range("M3").Resize(d1.Count) = Application.Transpose(d1.keys)
    Range("N3").Resize(d2.Count) = Application.Transpose(d2.keys)
    Range("O3").Resize(d3.Count) = Application.Transpose(d3.keys)
    Range("P3").Resize(d4.Count) = Application.Transpose(d4.keys)
    Range("Q3").Resize(d5.Count) = Application.Transpose(d5.keys)
    Range("R3").Resize(d6.Count) = Application.Transpose(d6.keys)
    Range("S3").Resize(d7.Count) = Application.Transpose(d7.keys)
    Range("T3").Resize(d8.Count) = Application.Transpose(d8.keys)
    Range("U3").Resize(d9.Count) = Application.Transpose(d9.keys)
    Range("V3").Resize(d10.Count) = Application.Transpose(d10.keys)
    
End Sub
 
Y

yesimgurol

Altın Üye
Katılım
8 Aralık 2011
Mesajlar
950
Excel Vers. ve Dili
Excel 2016,32bit
Altın Üyelik Bitiş Tarihi
18-11-2024
Ömer bey, harikasınız gerçekten çok teşekkür ederim. Emeğinize sağlık. Tam istediğim gibi çalışıyor.
 
ÖmerFaruk

ÖmerFaruk

Destek Ekibi
Destek Ekibi
Katılım
22 Ekim 2017
Mesajlar
4,779
Excel Vers. ve Dili
Microsoft 365 Tr-64
Aslında bu benim ilk Scripting.Dictionary denemem. Onu da sizin ilk kodlarınızdan kopyaladım direkt.
Çalışmaya ve öğrenmeye devam.

Harika olan Bilgiyi paylaştıkça güzelleşen Excel.Web.Tr
 
Y

yesimgurol

Altın Üye
Katılım
8 Aralık 2011
Mesajlar
950
Excel Vers. ve Dili
Excel 2016,32bit
Altın Üyelik Bitiş Tarihi
18-11-2024
ÖmerFaruk' Alıntı:
Doğru ben atlamışım. Aşağıda kodun komplesi var.

C++: 
Sub ozet2()
    Dim d As Object, i As Long, deg, son As Long, deg2
    Dim d1 As Object, d2 As Object, d3 As Object, d4 As Object, d5 As Object
    Dim d6 As Object, d7 As Object, d8 As Object, d9 As Object, d10 As Object

    Set d = CreateObject("Scripting.Dictionary")
    Set d1 = CreateObject("Scripting.Dictionary")
    Set d2 = CreateObject("Scripting.Dictionary")
    Set d3 = CreateObject("Scripting.Dictionary")
    Set d4 = CreateObject("Scripting.Dictionary")
    Set d5 = CreateObject("Scripting.Dictionary")
    Set d6 = CreateObject("Scripting.Dictionary")
    Set d7 = CreateObject("Scripting.Dictionary")
    Set d8 = CreateObject("Scripting.Dictionary")
    Set d9 = CreateObject("Scripting.Dictionary")
    Set d10 = CreateObject("Scripting.Dictionary")
  
    son = Cells(Rows.Count, "B").End(xlUp).Row
    Application.ScreenUpdating = False
    For i = 1 To son
        deg = Cells(i, "B")
        If Not d.exists(deg) Then
            d.Add deg, Nothing
        End If
        If i < 3 Then GoTo Devam
        If IsError(Cells(i, "I")) Then deg2 = "HATA": GoTo Atla1
        On Error Resume Next
        If Len(Cells(i, "I")) = 5 And Cells(i, "I") = 0 Then GoTo Devam
            deg2 = Cells(i, "I")
Atla1:
            Select Case Cells(i, "C")
            Case Cells(2, 13)
                d1.Add deg2, Nothing
            Case Cells(2, 14)
                d2.Add deg2, Nothing
            Case Cells(2, 15)
                d3.Add deg2, Nothing
            Case Cells(2, 16)
                d4.Add deg2, Nothing
            Case Cells(2, 17)
                d5.Add deg2, Nothing
            Case Cells(2, 18)
                d6.Add deg2, Nothing
            Case Cells(2, 19)
                d7.Add deg2, Nothing
            Case Cells(2, 20)
                d8.Add deg2, Nothing
            Case Cells(2, 21)
                d9.Add deg2, Nothing
            Case Cells(2, 22)
                d10.Add deg2, Nothing
            End Select
Devam:
    Next i
    Range("L:L").ClearContents
    Range("L1").Resize(d.Count) = Application.Transpose(d.keys)
    Range("M3").Resize(d1.Count) = Application.Transpose(d1.keys)
    Range("N3").Resize(d2.Count) = Application.Transpose(d2.keys)
    Range("O3").Resize(d3.Count) = Application.Transpose(d3.keys)
    Range("P3").Resize(d4.Count) = Application.Transpose(d4.keys)
    Range("Q3").Resize(d5.Count) = Application.Transpose(d5.keys)
    Range("R3").Resize(d6.Count) = Application.Transpose(d6.keys)
    Range("S3").Resize(d7.Count) = Application.Transpose(d7.keys)
    Range("T3").Resize(d8.Count) = Application.Transpose(d8.keys)
    Range("U3").Resize(d9.Count) = Application.Transpose(d9.keys)
    Range("V3").Resize(d10.Count) = Application.Transpose(d10.keys)
  
End Sub
Genişletmek için tıkla ...
Ömer bey tekrar merhaba kusura bakmayın yine bir ricam olacaktı. Aslında kendim eklemeye çalıştım oldu gibiydi yalnız daha önce bahsetmiş olduğum sıfır olduğunda kaydırma sorununu yaptı nedense. Ekleme yapmasam kod istediğim şekilde çalışıyor sorunsuz. Ama işte bir bölüm daha çıktı onu da eklemek istemiştim.:-(
Kodun son hali bu şekilde;
Kod: 
Sub ozetyenı()

   Dim d As Object, i As Long, deg, son As Long, deg2
    Dim d1 As Object, d2 As Object, d3 As Object, d4 As Object, d5 As Object
    Dim d6 As Object, d7 As Object, d8 As Object, d9 As Object, d10 As Object, d11 As Object

    Set d = CreateObject("Scripting.Dictionary")
    Set d1 = CreateObject("Scripting.Dictionary")
    Set d2 = CreateObject("Scripting.Dictionary")
    Set d3 = CreateObject("Scripting.Dictionary")
    Set d4 = CreateObject("Scripting.Dictionary")
    Set d5 = CreateObject("Scripting.Dictionary")
    Set d6 = CreateObject("Scripting.Dictionary")
    Set d7 = CreateObject("Scripting.Dictionary")
    Set d8 = CreateObject("Scripting.Dictionary")
    Set d9 = CreateObject("Scripting.Dictionary")
    Set d10 = CreateObject("Scripting.Dictionary")
    Set d11 = CreateObject("Scripting.Dictionary")
   
   
    son = Cells(Rows.Count, "B").End(xlUp).Row
    Application.ScreenUpdating = False
    For i = 1 To son
        deg = Cells(i, "B")
        If Not d.exists(deg) Then
            d.Add deg, Nothing
        End If
        If i < 3 Then GoTo Devam
        If IsError(Cells(i, "I")) Then deg2 = "HATA": GoTo Atla1
        On Error Resume Next
        If Len(Cells(i, "I")) = 5 And Cells(i, "I") = 0 Then GoTo Devam
            deg2 = Cells(i, "I")
Atla1:
            Select Case Cells(i, "C")
            Case Cells(2, 13)
                d1.Add deg2, Nothing
            Case Cells(2, 14)
                d2.Add deg2, Nothing
            Case Cells(2, 15)
                d3.Add deg2, Nothing
            Case Cells(2, 16)
                d4.Add deg2, Nothing
            Case Cells(2, 17)
                d5.Add deg2, Nothing
            Case Cells(2, 18)
                d6.Add deg2, Nothing
            Case Cells(2, 19)
                d7.Add deg2, Nothing
            Case Cells(2, 20)
                d8.Add deg2, Nothing
            Case Cells(2, 21)
                d9.Add deg2, Nothing
            Case Cells(2, 22)
                d10.Add deg2, Nothing
            Case Cells(2, 23)
                d11.Add deg2, Nothing
         
            End Select
Devam:
    Next i
    Range("L:L").ClearContents
    Range("L1").Resize(d.Count) = Application.Transpose(d.keys)
    Range("M3").Resize(d1.Count) = Application.Transpose(d1.keys)
    Range("N3").Resize(d2.Count) = Application.Transpose(d2.keys)
    Range("O3").Resize(d3.Count) = Application.Transpose(d3.keys)
    Range("P3").Resize(d4.Count) = Application.Transpose(d4.keys)
    Range("Q3").Resize(d5.Count) = Application.Transpose(d5.keys)
    Range("R3").Resize(d6.Count) = Application.Transpose(d6.keys)
    Range("S3").Resize(d7.Count) = Application.Transpose(d7.keys)
    Range("T3").Resize(d8.Count) = Application.Transpose(d8.keys)
    Range("U3").Resize(d9.Count) = Application.Transpose(d9.keys)
    Range("V3").Resize(d10.Count) = Application.Transpose(d10.keys)
    Range("W3").Resize(d11.Count) = Application.Transpose(d11.keys)
   
End Sub
 
ÖmerFaruk

ÖmerFaruk

Destek Ekibi
Destek Ekibi
Katılım
22 Ekim 2017
Mesajlar
4,779
Excel Vers. ve Dili
Microsoft 365 Tr-64
Nereye ne ekledinizi söyler misiniz? Ya da ekledim dediklerinizi renkli işaretleyerek dosyanızı yeniden paylaşır mısınız?
 
Y

yesimgurol

Altın Üye
Katılım
8 Aralık 2011
Mesajlar
950
Excel Vers. ve Dili
Excel 2016,32bit
Altın Üyelik Bitiş Tarihi
18-11-2024
ÖmerFaruk' Alıntı:
Nereye ne ekledinizi söyler misiniz? Ya da ekledim dediklerinizi renkli işaretleyerek dosyanızı yeniden paylaşır mısınız?
Genişletmek için tıkla ...
Merhaba Ömer bey ,
Kusura bakmayın iş yoğunluğundan tekrar giriş yapmak mümkün olmadı gün içerisinde:-(

Şöyle ki ,
Örnek dosyamın son halinde Modül 3'te bulunan kodlar her haliyle istemiş olduğum gibi çalışıyor. (Sizin 13 nolu mesajda vermiş olduğunuz kodlardır)
Modül 4'te yer alan kodlar ise bahsetmiş olduğum eklemelerin olduğu kodlar ve kodlar içerisinde eklemiş olduğum yerleri kesme işareti kullanarak açıklama olarak belirttim.

Aynı zamanda atlama yapılan yeri de belirtmiş oldum.
 

Ekli dosyalar

ÖmerFaruk

ÖmerFaruk

Destek Ekibi
Destek Ekibi
Katılım
22 Ekim 2017
Mesajlar
4,779
Excel Vers. ve Dili
Microsoft 365 Tr-64
Merhaba,
Items özelliğinden faydalanmak zaruret oldu. Key değerleri 1 den fazla olamıyor. Ben atlamışım.
Kodlarınızı yeniden düzenledim
C#: 
Sub ozetyenı()

   Dim d As Object, i As Long, deg, son As Long, deg2
    Dim d1 As Object, d2 As Object, d3 As Object, d4 As Object, d5 As Object
    Dim d6 As Object, d7 As Object, d8 As Object, d9 As Object, d10 As Object, d11 As Object 'd11 EKLENDİ

    Set d = CreateObject("Scripting.Dictionary")
    Set d1 = CreateObject("Scripting.Dictionary")
    Set d2 = CreateObject("Scripting.Dictionary")
    Set d3 = CreateObject("Scripting.Dictionary")
    Set d4 = CreateObject("Scripting.Dictionary")
    Set d5 = CreateObject("Scripting.Dictionary")
    Set d6 = CreateObject("Scripting.Dictionary")
    Set d7 = CreateObject("Scripting.Dictionary")
    Set d8 = CreateObject("Scripting.Dictionary")
    Set d9 = CreateObject("Scripting.Dictionary")
    Set d10 = CreateObject("Scripting.Dictionary")
    Set d11 = CreateObject("Scripting.Dictionary")
    
    
    son = Cells(Rows.Count, "B").End(xlUp).Row
    For i = 1 To son
        deg = Cells(i, "B")
        If Not d.exists(deg) Then
            d.Add deg, Nothing
        End If
        If i < 3 Then GoTo Devam
        If IsError(Cells(i, "I")) Then deg2 = "HATA": GoTo Atla1

        If Len(Cells(i, "I")) = 5 And Cells(i, "I") = 0 Then GoTo Devam
            deg2 = Cells(i, "I")
Atla1:
            Select Case Cells(i, "C")
            Case Cells(2, 13)
                d1key = d1key + 1
                d1.Add d1key, deg2
            Case Cells(2, 14)
                d2key = d2key + 1
                d2.Add d2key, deg2
            Case Cells(2, 15)
                d3key = d3key + 1
                d3.Add d3key, deg2
            Case Cells(2, 16)
                d4key = d4key + 1
                d4.Add d4key, deg2
            Case Cells(2, 17)
                d5key = d5key + 1
                d5.Add d5key, deg2
            Case Cells(2, 18)
                d6key = d6key + 1
                d6.Add d6key, deg2
            Case Cells(2, 19)
                d7key = d7key + 1
                d7.Add d7key, deg2
            Case Cells(2, 20)
                d8key = d8key + 1
                d8.Add d8key, deg2
            Case Cells(2, 21)
                d9key = d9key + 1
                d9.Add d9key, deg2
            Case Cells(2, 22)
                d10key = d10key + 1
                d10.Add d10key, deg2
            Case Cells(2, 23)
                d11key = d11key + 1
                d11.Add d11key, deg2
            End Select
Devam:
    Next i
    Range("L:L").ClearContents
    Range("L1").Resize(d.Count) = Application.Transpose(d.keys)
    Range("M3").Resize(d1.Count) = Application.Transpose(d1.Items)
    Range("N3").Resize(d2.Count) = Application.Transpose(d2.Items)
    Range("O3").Resize(d3.Count) = Application.Transpose(d3.Items)
    Range("P3").Resize(d4.Count) = Application.Transpose(d4.Items)
    Range("Q3").Resize(d5.Count) = Application.Transpose(d5.Items)
    Range("R3").Resize(d6.Count) = Application.Transpose(d6.Items)
    Range("S3").Resize(d7.Count) = Application.Transpose(d7.Items)
    Range("T3").Resize(d8.Count) = Application.Transpose(d8.Items)
    Range("U3").Resize(d9.Count) = Application.Transpose(d9.Items)
    Range("V3").Resize(d10.Count) = Application.Transpose(d10.Items)
    Range("W3").Resize(d11.Count) = Application.Transpose(d11.Items)
End Sub
 
Cevap yazmak için giriş yap yada kayıt ol.
Üst