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

yesimgurol · 15 Ağustos 2021

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:-(

ÖmerFaruk · 15 Ağustos 2021

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ı?

1Al2Ver · 15 Ağustos 2021

Merhaba,

Formülle (Topla.Çarpım) çözüm ektedir,

yesimgurol · 15 Ağustos 2021

Ö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ı?

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.

yesimgurol · 15 Ağustos 2021

1Al2Ver' Alıntı:
Merhaba,

Formülle (Topla.Çarpım) çözüm ektedir,

Merhaba sayın 1Al2Ver,
Emeğinize sağlık çok teşekkür ederim. Tam istediğim şekilde olmuş.
Kodlar ile olmazsa bu şekilde de kullanım sağlarım artık.

ÖmerFaruk · 15 Ağustos 2021

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

yesimgurol · 16 Ağustos 2021

Ö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

Merhaba Ömer bey,
Harika olmuş emeğinize sağlık çok teşekkür ederim.

yesimgurol · 16 Ağustos 2021

Ö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

Ö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?

ÖmerFaruk · 16 Ağustos 2021

#DEĞER hatası varsa ne yapacak?

yesimgurol · 16 Ağustos 2021

ÖmerFaruk' Alıntı:
#DEĞER hatası varsa ne yapacak?

"HATA" yazabilir mi ki acaba .

ÖmerFaruk · 16 Ağustos 2021

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:

yesimgurol · 16 Ağustos 2021

Ömer bey ,
"End Select" altındaki "End If" kısmında uyarı veriyor.

ÖmerFaruk · 16 Ağustos 2021

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

yesimgurol · 16 Ağustos 2021

Ömer bey, harikasınız gerçekten çok teşekkür ederim. Emeğinize sağlık. Tam istediğim gibi çalışıyor.

ÖmerFaruk · 16 Ağustos 2021

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

yesimgurol · 16 Ağustos 2021

ÖmerFaruk' Alıntı:
Harika olan Bilgiyi paylaştıkça güzelleşen Excel.Web.Tr

Kesinlikle katılıyorum.

yesimgurol · 17 Ağustos 2021

Ö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

Ö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 · 17 Ağustos 2021

Nereye ne ekledinizi söyler misiniz? Ya da ekledim dediklerinizi renkli işaretleyerek dosyanızı yeniden paylaşır mısınız?

yesimgurol · 17 Ağustos 2021

Ö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?

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.

ÖmerFaruk · 17 Ağustos 2021

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

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

yesimgurol

Ekli dosyalar

ÖmerFaruk

Destek Ekibi

1Al2Ver

Ekli dosyalar

yesimgurol

yesimgurol

ÖmerFaruk

Destek Ekibi

yesimgurol

yesimgurol

Ekli dosyalar

ÖmerFaruk

Destek Ekibi

yesimgurol

ÖmerFaruk

Destek Ekibi

yesimgurol

ÖmerFaruk

Destek Ekibi

yesimgurol

ÖmerFaruk

Destek Ekibi

yesimgurol

yesimgurol

ÖmerFaruk

Destek Ekibi

yesimgurol

Ekli dosyalar

ÖmerFaruk

Destek Ekibi