Sıralama Biçimi

[HitMan]

Merhaba elimde Sql den aldığım ve bu şekilde almak zorunda olsuğum bir excel dosyası ve içinde kod sıralamalarım var.
Şöyle ki;
Bir stok kodum ve bu stok koduna bağlı bir özel kod ve açıklaması var toplam 3 kolon ancak sql den aldığım çıktı stok koduna göre sıralanmış hali, ve her stok kodunun karşılığında açıklması dolu olanları getirmiş yani boş olanları sıarası ile karşıma gelmiyor.

Benim istediğim excelde diğer sheet de ki gibi özel kod sıralamasına göre stok kodunun açıklamalarını getirmesi.

Sanırım karışık oldu ama dosyada örnek ile anlatmaya çalıştım.

Teşekkürler.

 

[Ferhat Pazarçevirdi]

Evet biraz karışık anlatmışsınız

SQL'den geldiğini söylediğiniz ham veriler hangi sheet'de ?

 

[HitMan]

Orjinal yazan sheette biçim diğeri gibi olması gerekiyor. :S

 

[Ferhat Pazarçevirdi]

Eğer sorunuzu doğru anlayabildiysem; aşağıdaki kodları çalıştırarak deneyiniz. Tablo şeklinde dizayn ettiğiniz sheet'in ilgili hücreleri, diğer liste şeklindeki sheetten bilgiler alınarak, doldurulacaktır.

NOT : İşlem süresi, bilgisayarının işlemcisine bağlı olarak uzun sürebilir.

Sub Aktar()
Dim diziara() As Variant
Set Sh = Sheets("STOKKARTOZELKODLAR (ORJINAL)")
Set sh2 = Sheets("RAPRO ÖZELKOD TABLO İSTEK ÖRNEK")
sh2.Range("A3:IV" & sh2.Cells(65536, 1).End(xlUp).Row + 1).ClearContents
y = 3
For i = 2 To Sh.Cells(65536, 1).End(xlUp).Row
    X = Application.WorksheetFunction.CountIf(Sh.Range("A2:A" & i), Sh.Cells(i, 1))
    If X = 1 Then
       sh2.Cells(y, 1) = Sh.Cells(i, 1)
       ReDim diziara(1 To Application.WorksheetFunction.CountIf(Sh.Range("A:A"), sh2.Cells(y, 1)), 1 To 2)
       Set bul = Sh.Columns(1).Find(sh2.Cells(y, 1), LookAt:=xlWhole)
       
       If Not bul Is Nothing Then
          Adres = bul.Address
          Do
               m = m + 1
               If bul.Column > 1 Then GoTo f1
               diziara(m, 1) = bul.Offset(0, 1).Value
               diziara(m, 2) = bul.Offset(0, 2).Value
               Set bul = Sh.Cells.FindNext(bul)
          Loop While Not bul Is Nothing And bul.Address <> Adres
       End If
       
       For z = 1 To m
           Set bul2 = sh2.Rows(2).Cells.Find(diziara(z, 1), LookAt:=xlWhole)
           sh2.Cells(y, bul2.Column) = diziara(z, 2)
           Set bul2 = Nothing
       Next z
f1:
       m = 0
       y = y + 1
    End If
Next i
Set Sh = Nothing
Set sh2 = Nothing
End Sub

 

[HitMan]

Tek kelime ile "mükemmel" - Hep Heroes dizisinde ki Peter in yeteneklerinden bahsederdim, şimdi senden bahsedeceğim.
Çok Teşekkürler.