Aktarma işlemi olmuyor

[ockucukay]

Ekte göreceğiniz gibi; bir bakım planımız var. Haftalık Liste-Planlı sayfasında seçilen haftaya göre mesela 15.hafta seçilmiş olsun, o hafta bakımı yapılacak tezgahlar ile ilgili bilgileri Haftalık Liste-Planlı sayfasına yazdırmak istiyorum.Aşağıdaki kodu aktarma için kullanıyorum ama hiç bir şey yapmadan "İşlem tamamlandı" mesajını verip bitiriyor. Yardımlarınızı bekliyorum.

Sub PlanlıBakımAktar()

On Error Resume Next
Set S1 = Sheets("Bakım Planı")
Set S2 = Sheets("Haftalık Liste-Planlı")
SON = S1.[A65536].End(3).Row
S2.Select
[A3:E65536].ClearContents
For x = 3 To [A65536].End(3).Row
For Y = 1 To 5
Cells(x, Y) = Evaluate("SUMPRODUCT(--('Bakım Planı'!B2:B" & SON & "=" & Cells(x, 2).Address(0, 0) & "),--('Bakım Planı'!C2:C" & SON & "=" & Cells(2, Y).Address(0, 0) & "),('Bakım Planı'!E2:E" & SON & "))")
Next
Next
Set S1 = Nothing
Set S2 = Nothing
MsgBox "İŞLEMİNİZ TAMAMLANMIŞTIR.", vbInformation
End Sub

 

[mancubus]

[A3:E65536].ClearContents
For x = 3 To [A65536].End(3).Row

[A3:E65536].ClearContents satırı S2'de 3. satırdan sonrasını siliyor.
dolayısı ile [A65536].End(3).Row kısmı 2 olacaktır.

For x = 3 To 2'ye dönüşecek ve bu örnekte anlamsız olacaktır.

S2'de hagi satıra kadar işlem yapılacaksa [A65536].End(3).Row yerine onu yazarak denemekte fayda var.

 

[Korhan Ayhan]

Merhaba,

Sn. mancubus'un yorumuna ek olarak döngü içinde kullandığınız topla.çarpım formülünün hangi alanları sorgulaması gerekiyor. Bana sanki hücre adreslerinde bir sorun var gibi geldi.

Ben döngüyü çalışır hale getirip formülü bir hücreye yazdırdığımda aşağıdaki sonuç çıktı.

SUMPRODUCT(--('Bakım Planı'!B2:B167=[COLOR=red]B3[/COLOR]),--('Bakım Planı'!C2:C167=[COLOR=red]A2[/COLOR]),('Bakım Planı'!E2:E167))

Kırmızı renkli hücre adreslerinde sorun var görünüyor.

 

[ockucukay]

Merhaba

Cevaplarınız için teşekkür ederim. Yazdığım makro eksik veya yanlış olabilir. Yapmak istediğim şu: Haftalık Liste-Planlı sayfası B1 değerini, bakım planı sayfasında E,G,I,K,M,O,Q,S,U,W,Y,AA sütünlarında aratacağım. Bulunan değerlerin ait olduğu makina bilgilerini (tezgah no, makina adı, sıklık, bakım tarihi) Haftalık Liste-Planlı sayfasına aktarmak. Umarım sağlıklı anlatabilmişimdir. Yardımlarınız için tekrar teşekkür ederim.

 

[Korhan Ayhan]

Merhaba,

Aşağıdaki kodu denermisiniz.

E sütununa hangi bilginin geleceğini belirtmediğiniz için boş bıraktım. Kendinize göre başında tek tırnak olan kod satırını düzenleyiniz.

Sub PlanlıBakımAktar()
    Dim S1 As Worksheet, S2 As Worksheet
    Dim BUL As Range, ADRES As String, Satır As Long
    
    Application.ScreenUpdating = False
    
    Set S1 = Sheets("Bakım Planı")
    Set S2 = Sheets("Haftalık Liste-Planlı")
    
    S2.Select
    Range("A3:E65536").ClearContents
    SON = S1.Range("A65536").End(3).Row
    Satır = 3
    
    Set BUL = S1.Range("E:AA").Find(S2.Range("B1"), , xlValues)
    If Not BUL Is Nothing Then
        ADRES = BUL.Address
        Do
            S2.Cells(Satır, 1) = S1.Cells(BUL.Row, "A")
            S2.Cells(Satır, 2) = S1.Cells(BUL.Row, "B")
            S2.Cells(Satır, 3) = S1.Cells(BUL.Row, "C")
            S2.Cells(Satır, 4) = S1.Cells(BUL.Row, "D")
            'S2.Cells(Satır, 5) = S1.Cells(BUL.Row, "E")
            Satır = Satır + 1
            Set BUL = S1.Range("E:AA").FindNext(BUL)
        Loop While Not BUL Is Nothing And BUL.Address <> ADRES
    End If
    
    Set BUL = Nothing
    Set S1 = Nothing
    Set S2 = Nothing
    
    Application.ScreenUpdating = True
    
    MsgBox "İşleminiz tamamlanmıştır.", vbInformation
End Sub

 

[ockucukay]

Merhaba hocam

Kod için teşekkür ederim. Çok güzel çalıştı. Yeni yıl hediyenize teşekkürler.