Dizi içindeki verilerin koşula bağlı olarak benzersizlerini bulup sayfalara yazdırma

[gnorar]

Arr(0 To n, 1) adında bir dizim var. Diziyi basit bir şekilde aşağıya örnekleyeyim.


İstanbul ---Bigisayar Malzemeleri
Ankara ----Bigisayar Malzemeleri
Bursa -----Bigisayar Malzemeleri
Ankara ----Bigisayar Malzemeleri
İstanbul ---Ev malzemeleri
Bursa -----Ev malzemeleri
Bursa -----Ev malzemeleri
Ankara ----Bigisayar Malzemeleri
Ankara ----Bigisayar Malzemeleri
İstanbul ---Ev malzemeleri
İstanbul ---Ev malzemeleri
İstanbul ---Ev malzemeleri

Hazırladığım makroda 2. Sütunun benzersizlerini bulup onlara ait yeni sayfalar oluşturuyorum. (Yani Bilgisayar Malzemeleri ve Ev Malzemeleri adında iki sayfa oluşturuyorum.)

Yapmak istediğim örnekteki malzemeler hangi illerde varsa daha önce oluşturmuş olduğum malzeme sayfalarına o illeri benzersiz olarak yazdırmak.
Yani Bilgisayar Malzemeleri sayfasının A1 hücresine İstanbul, B1 hücresine Ankara, C1 hücresine Bursa, Ev Malzemeleri sayfasının A1 hücresine İstanbul, B1 hücresine Bursa yazdırılması gerekli. (İller yazdırılırken harf sırasına göre yazdırılabilirse çok daha mükemmel olur.)

Diz büyük olduğu için hızlı bir yöntem avantaj kazandırır. (CreateObject("Scripting.Dictionary") yöntemiyle çok uğraştım ama ne yazık ki beceremedim.)
Bu konuyla ilgili yardımlarınız bekliyorum. En ufak bir yardım dahi benim için gerçekten önemli. Şimdiden teşekkürler.

 

[Orion1]

Örnek dosyayı inceleyiniz.

Option Base 1
Sub dizi_59()
Dim myarr(), i As Long, sat As Long
Application.ScreenUpdating = False
myarr = Sheets(1).Range("A1:B" & Sheets(1).Cells(65536, "B").End(xlUp).Row).Value
For i = LBound(myarr) To UBound(myarr)
    sat = Sheets(myarr(i, 2)).Cells(65536, "B").End(xlUp).Row + 1
    Sheets(myarr(i, 2)).Cells(sat, "A").Value = myarr(i, 1)
    Sheets(myarr(i, 2)).Cells(sat, "B").Value = myarr(i, 2)
Next
For i = 2 To Worksheets.Count
    Sheets(i).Range("A2:B" & Sheets(i).Range("B65536").End(xlUp).Row).Sort Sheets(i).Range("A2")
Next
Application.ScreenUpdating = True
MsgBox "İşlem tamamlandı." & vbLf & "evrengizlen@hotmail.com" & vbLf & "23.07.2011", vbOKOnly + vbInformation, "E V R E N"
End Sub

 

[gnorar]

Sn. Evren Gizlen öncelikle yanıtınız için teşekkür ederim.

Ancak yapmak istediğim malzeme sayfalarına sadece illeri tekrarlama olmaksızın yazdırmak. Yani Bilgisayar Malzemeleri sayfasının B2 hücresine İstanbul, C2 hücresine Ankara,D2 hücresine Bursa, Ev Malzemeleri sayfasının B2 hücresine İstanbul, C2 hücresine Bursa yazdırılması gerekli. Doğru sayfaların olduğu bir örneği aşağıda ekledim.

Bu arada verdiğim örnekte sadece 2 adet malzeme çeşidi var (ev ve bilgisayar). Asıl dosyada ise malzeme çeşidi çok fazla. Bunu da dikkate alırsanız sevinirim.

Yardımlarınız için bir daha teşekkür ederim.

 

[Orion1]

Sn. Evren Gizlen öncelikle yanıtınız için teşekkür ederim.

Ancak yapmak istediğim malzeme sayfalarına sadece illeri tekrarlama olmaksızın yazdırmak. Yani Bilgisayar Malzemeleri sayfasının B2 hücresine İstanbul, C2 hücresine Ankara,D2 hücresine Bursa, Ev Malzemeleri sayfasının B2 hücresine İstanbul, C2 hücresine Bursa yazdırılması gerekli. Doğru sayfaların olduğu bir örneği aşağıda ekledim.

Bu arada verdiğim örnekte sadece 2 adet malzeme çeşidi var (ev ve bilgisayar). Asıl dosyada ise malzeme çeşidi çok fazla. Bunu da dikkate alırsanız sevinirim.

Yardımlarınız için bir daha teşekkür ederim.

dosyanız ektedir.:cool:
Option Base 1
Sub dizi_59()
Dim myarr(), i As Long, sat As Long, z As Object, deg As String
Application.ScreenUpdating = False
myarr = Sheets(1).Range("A1:B" & Sheets(1).Cells(65536, "B").End(xlUp).Row).Value
Set z = CreateObject("Scripting.Dictionary")
For i = LBound(myarr) To UBound(myarr)
    deg = myarr(i, 1) & "-" & myarr(i, 2)
    If Not z.exists(deg) Then
        z.Add deg, Nothing
        sat = Sheets(myarr(i, 2)).Cells(65536, "B").End(xlUp).Row + 1
        Sheets(myarr(i, 2)).Cells(sat, "B").Value = myarr(i, 1)
        'Sheets(myarr(i, 2)).Cells(sat, "B").Value = myarr(i, 2)
    End If
Next
Set z = Nothing
Erase myarr
For i = 2 To Worksheets.Count
    Sheets(i).Range("B2:B" & Sheets(i).Range("B65536").End(xlUp).Row).Sort Sheets(i).Range("B2")
Next
Application.ScreenUpdating = True
MsgBox "İşlem tamamlandı." & vbLf & "evrengizlen@hotmail.com" & vbLf & "23.07.2011", vbOKOnly + vbInformation, "E V R E N"
End Sub

 

[gnorar]

Sn. Orion1, tatil nedeniyle yanıtınıza cevap veremedim. Makronuz doğru olarak çalımakta. Ancak kodlarınızı kendi kodlarıma adapte edemedim. Yardımlarınız için teşekkür ederim.