veri listelemek yardım!!

[nongeyikm]

Selam arkadaşlar

ekteki örnek dosyamda yer alan çalışma kitabı içindeki "personel ana liste"nin F sütununa bakarak kod var ise bunu diğer çalışma sayfası olan "ÜRETİM MERKEZLERİ" sayfasında o koda karşılık gelen kutunun içinde aynı kodların detaylarını (B,C,G sütünlarındaki değerleri) listelemesi. üretim merkezlerinde şu an için 12 tane kod grubu var.

yardımlarınız için teşekkür.

Bu arada Halit Bey e de yardımları için sonsuz teşekkür.

Saygılar,

 

[N.Ziya Hiçdurmaz]

yanıt

Diğer sütünlar için aşşağıdaki kodları adreslerini değiştirerek çoğaltabilirsiniz

Sub aktar()
Dim sat, s As Integer
Sayfa1.[a8:c67] = Empty
s = 8
    For sat = 7 To 602
        If Sheet19.Cells(sat, "f") Like Sayfa1.[a6] Then
         Range(Sheet19.Cells(sat, "b"), Sheet19.Cells(sat, "c")).Copy
         Range(Sayfa1.Cells(s, "a"), Sayfa1.Cells(s, "b")).PasteSpecial xlValues
         Sheet19.Cells(sat, "g").Copy
         Sayfa1.Cells(s, "c").PasteSpecial xlValues
         s = s + 1
        End If
    Next
    '*****
  Sayfa1.[d8:f67] = Empty
s = 8
    For sat = 7 To 602
        If Sheet19.Cells(sat, "f") Like Sayfa1.[d6] Then
         Range(Sheet19.Cells(sat, "b"), Sheet19.Cells(sat, "c")).Copy
         Range(Sayfa1.Cells(s, "d"), Sayfa1.Cells(s, "e")).PasteSpecial xlValues
         Sheet19.Cells(sat, "g").Copy
         Sayfa1.Cells(s, "f").PasteSpecial xlValues
         s = s + 1
        End If
    Next
            
End Sub

 

[halit3]

alternatif olarak bir kodda benden

yanlız "ÜRETİM MERKEZLERİ" sayfası D6 hücresindeki değerde yanlışlık var doğrusu bu olmalı herhalde "N-TO-01"

Sub aktar1()
deg1 = 0
yer2 = 0
For i = 1 To 67
yer1 = Worksheets("ÜRETİM MERKEZLERİ").Cells(i, 255).End(xlToLeft).Column
If deg1 > yer1 Then
deg1 = deg1
Else
deg1 = yer1
End If
Next i

For sut = 1 To deg1
'Cells(6, sut).Select
sat = 8
For i = 6 To 500
If Worksheets("ÜRETİM MERKEZLERİ").Cells(6, sut).Value = Worksheets("Personel ANA LİSTE").Cells(i, 6).Value Then
Worksheets("ÜRETİM MERKEZLERİ").Cells(sat, sut).Value = Worksheets("Personel ANA LİSTE").Cells(i, 2).Value
Worksheets("ÜRETİM MERKEZLERİ").Cells(sat, sut + 1).Value = Worksheets("Personel ANA LİSTE").Cells(i, 3).Value
Worksheets("ÜRETİM MERKEZLERİ").Cells(sat, sut + 2).Value = Worksheets("Personel ANA LİSTE").Cells(i, 7).Value
sat = sat + 1
End If
Next i
sut = sut + 2
Next sut

End Sub

 

[nongeyikm]

üstadlar llerinize sağlık.

Halit Bey günaydın,

makroyu alttaki sıra için de uyarlayabilirmisiniz. 8-67 (67 de bitmesi gerekir) tamam 75-134.satırlarda da yapabilirmiyiz?

Teşekkürler

 

[halit3]

üstadlar llerinize sağlık.

Halit Bey günaydın,

makroyu alttaki sıra için de uyarlayabilirmisiniz. 8-67 (67 de bitmesi gerekir) tamam 75-134.satırlarda da yapabilirmiyiz?

Teşekkürler

sat = 8
For i = 6 To 500

yukarıdaki kodu aşağıdakiyle değiştir

sat = 75
For i = 73 To 500

 

[nongeyikm]

Halit Bey,

Ben bu makroyu bir türlü uyarlayamadım 8 den 67 ye kadar ve 75 ten 134
de kadar tabloda değerler var tamamını yazıp gönderebilirmisiniz.

Teşekkürler

 

[halit3]

Halit Bey,

Ben bu makroyu bir türlü uyarlayamadım 8 den 67 ye kadar ve 75 ten 134
de kadar tabloda değerler var tamamını yazıp gönderebilirmisiniz.

Teşekkürler

kod aşağıdaki mesajda

 

[halit3]

kodu yeniden gönderiyorum Personel ANA LİSTE sayfasında eşleşen veri yok olmadığı için boş geçiyor yukarıdaki kodu bununla değiştir

Sub aktar2()
deg1 = 0
yer2 = 0
For i = 1 To 1000
yer1 = Worksheets("ÜRETİM MERKEZLERİ").Cells(i, 255).End(xlToLeft).Column
If deg1 > yer1 Then
deg1 = deg1
Else
deg1 = yer1
End If
Next i
For sut = 1 To deg1
'Cells(6, sut).Select
sat = 75
For i = 6 To 500
If Worksheets("ÜRETİM MERKEZLERİ").Cells(73, sut).Value = Worksheets("Personel ANA LİSTE").Cells(i, 6).Value Then
Worksheets("ÜRETİM MERKEZLERİ").Cells(sat, sut).Value = Worksheets("Personel ANA LİSTE").Cells(i, 2).Value
Worksheets("ÜRETİM MERKEZLERİ").Cells(sat, sut + 1).Value = Worksheets("Personel ANA LİSTE").Cells(i, 3).Value
Worksheets("ÜRETİM MERKEZLERİ").Cells(sat, sut + 2).Value = Worksheets("Personel ANA LİSTE").Cells(i, 7).Value
sat = sat + 1
End If
Next i
sut = sut + 2
Next sut

End Sub

 

[nongeyikm]

Halit Bey,

Çok çok teşekkürler

ikinci bir makro adı altında yapılacağını düşünmediğimden becerememiştim. Ama tablomu yanyana yaparak aktar 1 ile tamamını hallettim.

tekrar tekrar teşekkür.

 

[halit3]

Halit Bey,

Çok çok teşekkürler

ikinci bir makro adı altında yapılacağını düşünmediğimden becerememiştim. Ama tablomu yanyana yaparak aktar 1 ile tamamını hallettim.

tekrar tekrar teşekkür.

iyi çalışmalar