dizi hatası

[şehiriçi]

Merhaba Arkadaşlar,
Ekteki dosyamda K4 sütunundan B sütunundaki araçlardan en az 1 tane yazdırmaya çalışıyorum , basit bir hata yaptığımı düşünüyorum ama tüm plakalardan en az 1 tane olmak üzere yazdıramadım ,birde kodun başına tüm sayfayı silmesini ama renkli hücreleri de silmesini istiyorum ,desteğiniz bekliyorum iyi günler.

 

[Necdet]

Merhaba,

Tüm plakaları benzersiz olarak diziye almak istiyorsanız K4 hücresinden neden söz ediyorsunuz, K4 hücresini dikkate almak gerekiyorsa tüm plakaları ne yapacaksınız?

Valla kafam karıştı

 

[şehiriçi]

haklısınız Necdet bey eksik anlatmışım.
şöyleki sayfada F sütunundaki Hat1 in karşısındaki B sütunudaki plakayı K4 sütunundan itibaren benzersiz yazdırmak istiyorum.
Ayrıca şimdiden şunuda ifade edeyimki, Hat2 ve Hat3 ün karşısında B sütunundakileride L ve M sütununa yazdıracağım

 

[Erdem Akdemir]

Merhaba,

Aşağıdaki kodu kullanabilirsiniz.

Sub dizihatasi()
 
Range("K:K").ClearContents
 
Set con = VBA.CreateObject("adodb.Connection")

con.Open "provider=microsoft.ace.oledb.12.0;data source=" & _
ThisWorkbook.FullName & ";extended properties=""Excel 12.0;hdr=no"""

Set rs = con.Execute("select distinct f7 from[sayfa1$] where f7 is not null")

Range("K4").CopyFromRecordset rs

End Sub

 

[şehiriçi]

erdem bey ilginize çok teşekkür ederim ama gerçek dosyamda ben ado kullanmıyorum daha doğrusu ado hakkında hiç bilgim yok diğer kodlarla uyumlu olmuyor o yüzden mümkünse ado olmadan ...benim esas sıkıntım sonuna kadar geliyorum son kod olan
Range("K4").Resize(say - 1) = birdizi
bu kod K4:K9 arasına hep 42 GBC 04 plakayı yazdırıyor
oysa :
K4 = 42 GBC 04
k5 = 42 GBC 07
K4 = 42 GBC 09
k5 = 42 GBC 19
K4 = 42 GBC 23
k5 = 42 GBC 25
olması gerekiyor.

 

[Necdet]

Merhaba,
Doğru mu anladım, kodları bir deneyin, farklı yöntem olsun.

Public Sub Tek()
'Referanslardan Microsoft Sicripting.Runtime Seçili olmalı
Dim arr As Variant
Dim dic As New Dictionary
Dim i As Long
Dim j As Long

arr = Range("A4:H" & Cells(Rows.Count, "A").End(3).Row).Value

For i = LBound(arr, 1) To UBound(arr, 1)
    If arr(i, 6) = "Hat1" Then
        If Not dic.Exists(arr(i, 2)) Then
            j = j + 1
            dic.Add arr(i, 2), j
            arr(j, 1) = arr(i, 2)
        End If
    End If
Next i

Range("K4").Resize(j, 1) = arr

End Sub

 

[Necdet]

bu uygulamaya yönelik daha kısa kod

Public Sub Tek1()
'Referanslardan Microsoft Sicripting.Runtime Seçili olmalı
Dim arr As Variant
Dim dic As New Dictionary
Dim i As Long
Dim j As Long

arr = Range("A4:H" & Cells(Rows.Count, "A").End(3).Row).Value

For i = LBound(arr, 1) To UBound(arr, 1)
    If arr(i, 6) = "Hat1" Then
        If Not dic.Exists(arr(i, 2)) Then
            dic.Add arr(i, 2), 1
        End If
    End If
Next i

arr = dic.Keys

Range("K4").Resize(dic.Count, 1) = arr

End Sub

 

[şehiriçi]

Necdet moderatörüm ,son verdiğiniz kodu kullanmayı düşünüyorum .Ancak kod hata veriyor daha doğrusu yine K4:K9 aralığı 42 GBC 04 ekte dosyay uyarladım . birde ilave olacak ama,F sütununda ayrıca Hat2 ve Hat3 var onların karşısındaki plakaları da K dan sonraki L ve M sütunlarına yazdırabilirmisiniz.

 

[Necdet]

Merhaba,
Hata almanız normal. ben kod içinde açıklama olarak Microsoft Scripting Runtime'ın yüklenmesi gerektiğini belirtmişim, siz buna dikkat etmemişsiniz.
Ben CreateObject("Sicripting.Dictionary") kullanmayı sevmiyorum, o yüzden referanslardan Microsoft Scripting Runtime'ı yüklüyorum.

Sub Tekk()
'Referanslardan Microsoft Sicripting.Runtime Seçili olmalı
Dim arr As Variant
Dim dic As New Dictionary
Dim hatlar As Variant
Dim keys As Variant
Dim i As Long
Dim j As Long

hatlar = Array("Hat1", "Hat2", "Hat3")

arr = Range("A4:H" & Cells(Rows.Count, "A").End(3).Row).Value

For j = LBound(hatlar) To UBound(hatlar)
    For i = LBound(arr, 1) To UBound(arr, 1)
        If arr(i, 6) = hatlar(j) Then
            If Not dic.Exists(arr(i, 2)) Then
                dic.Add arr(i, 2), 1
            End If
        End If
    Next i
    
    keys = dic.keys
    
    Cells(4, j + 11).Resize(dic.Count, 1) = Application.WorksheetFunction.Transpose(keys)
    Set dic = Nothing
    
Next j

End Sub

/CODE]

 

[veyselemre]

Sub hatPlakalari()
    Dim arr, i&, sat&, sut%, sat1&, sat2&, sat3&, hat$, plk$, ky$
    arr = Range("A4:H" & Cells(Rows.Count, "A").End(3).Row).Value
    ReDim lst(1 To UBound(arr), 1 To 3)
    With CreateObject("Scripting.Dictionary")
        For i = LBound(arr, 1) To UBound(arr, 1)
            hat = arr(i, 6)
            plk = arr(i, 2)
            ky = hat & "|" & plk
            If Not .exists(ky) Then
                .Item(ky) = Null
                Select Case hat
                    Case "Hat1": sut = 1: sat1 = sat1 + 1: sat = sat1
                    Case "Hat2": sut = 2: sat2 = sat2 + 1: sat = sat2
                    Case "Hat3": sut = 3: sat3 = sat3 + 1: sat = sat3
                    Case Else
                        MsgBox "Hat Bulunamadı": Exit Sub
                End Select
            End If
            lst(sat, sut) = plk
        Next i
    End With

    Range("K4").Resize(WorksheetFunction.Max(sat1, sat2, sat3), 3).Value = lst
End Sub

 

[şehiriçi]

Necdet ve veyselemre ...desteğiniz için minnettarım elinize, emeğinize sağlık.

Necdet Bey gerçek dosya değişik bilgisayarlarda çalışma durumu var ,ben kendi bilgisayarımda dediğinizi yaparım sorun olmaz ama başka bir bilgisayarda Microsoft Sicripting.Runtime yı aktif etmeyi minibüscü aradaşlar yapamazlar o yüzden ben özellikle
CreateObject("Scripting.Dictionary") yı tercih ediyorum .Merak ediyorum aynı kod değilmi bunlar farkı nedir ? CreateObject("Scripting.Dictionary") bu koda uyarlayabilirmisiniz ve son olarak bu 3 hattı K,L,M sütununa değilde aralarına 7 şer sütun ilave ederek K,R,Y sütunlarına yazdırbilirmisiniz.

veyselemre çok tyeşekkür ederim ,mükemmel olmuş ,sizden bir ilave isteyebilirmiyim, bir üst satırda mümkünse Necdet beyden rica ettiğim şeyi
Yani K4 , R4 ve Y4 sütunlarına yazdırabilirmisiniz ben uğraştım yapamadım inanın gerçek sayfada 7 şer sütun atlayıyorum da...Saygılarımla.

 

[Necdet]

Merhaba
siz mevcut dosyada Microsoft Sicripting.Runtime'ı eklediğinizde o dosyada eklenmiş olur, dosyayı dağıttınızda sorun olmaz.
Önerdiğim yöntem erken bağlama oluyor.
Benim kodlarda dic. dediğinzde kullanabileceğiniz komutları görebilirsiniz, ama sizin kullandığınız yöntemde bunu göremezsiniz, tüm komutları bilmeniz gerekir.

sayfaya yazdıran :

Cells(4, j + 11).Resize(dic.Count, 1) = Application.WorksheetFunction.Transpose(keys)

Şu şekilde düzenleyin :

Cells(4, 11 + j * 7).Resize(dic.Count, 1) = Application.WorksheetFunction.Transpose(keys)

Linki inceleyiniz

 

[şehiriçi]

siz mevcut dosyada Microsoft Sicripting.Runtime'ı eklediğinizde o dosyada eklenmiş olur, dosyayı dağıttınızda sorun olmaz.


Teşekkürler Necdet bey ,ben runtime yı ekliyorum kopya dosya da gittiği bilgisayarda ayrıca eklemeye gerek kalmıyor demek ,ben böyle olduğunu bilmiyordum gittiği bilgisayarda da eklenecek zannediyordum . Ayrıca . dan sonra tüm komutları görmek çok faydalı hızıda değişiyor .
Tamamdır. Ayrıca link için Teşekkürler

 

[şehiriçi]

siz mevcut dosyada Microsoft Sicripting.Runtime'ı eklediğinizde o dosyada eklenmiş olur, dosyayı dağıttınızda sorun olmaz.

Teşekkürler Necdet bey ,ben runtime yı ekliyorum kopya dosya da gittiği bilgisayarda ayrıca eklemeye gerek kalmıyor demek ,ben böyle olduğunu bilmiyordum gittiği bilgisayarda da eklenecek zannediyordum . Ayrıca . dan sonra tüm komutları görmek çok faydalı hızıda değişiyor .
Tamamdır. Ayrıca link için Teşekkürler

 

[şehiriçi]

Sayın veyselemre Necdet beyin kodu Microsoft Sicripting.Runtime'ı referanslardan aktif ederek kullanıyorum.Ancak sizin kodu da yedekte tutmak istiyorum , o yüzden verdiğiniz kodun son satırındaki kod da revize edebilirmisiniz .
Yani K4 , R4 ve Y4 sütunlarına yazdırabilirmisiniz , gerçek dosya da 7 şer sütun atlıyorum da.