sayfadan sayfaya en son veri aktarma

[bursacem]

değerli hocalarım ekteki dosyada açıklamaları olarak ne yapmak istediğimi anlattım.
h001 nolu tezgahta birinci veri girişinde tüm bilgiler girilmiş.Fakat ikinci girişte devir değişim işlemi yapıldığında sadece iş emri no -iş emri tarihi ve devir hücreleri değişmiştir. diğer bilgiler bir önceki girişle aynı olduğu için girilmemiştir.Üretimtablosu sayfasında ise ise tezgah no'ya göre(artan sırayla) güncel tablo hazırlanmak istenmektedir.


lütfen acil yardımlarınızı bekliyorum.çok çok önemliiiiiiii

 

[Korhan Ayhan]

Aşağıdaki kodu deneyiniz.

Ayrıca forum kurallarına uygun başlıklar açınız. Açtığınız tüm başlıklar düzeltmediğiniz sürece "FORUM KURALLARINA UYMAYAN BAŞLIKLAR" bölümüne taşınmaktadır. Lütfen bu konuya özen gösteriniz.

Bu konuyla ilgili açmış olduğunuz mükerrer başlıkları hepsi geri dönüşüme taşınmıştır...

Option Explicit

Sub SON_VERILERI_AKTAR()
    Dim S1 As Worksheet, S2 As Worksheet
    Dim X As Long, Y As Byte, Bul As Range, Satir As Long
    
    Application.ScreenUpdating = False
    
    Set S1 = Sheets("veri")
    Set S2 = Sheets("üretimtablosu")
    
    S1.Columns("AA:AA").Clear
    S1.Columns("D:D").AdvancedFilter Action:=xlFilterCopy, CopyToRange:=S1.Range("AA1"), Unique:=True
    S2.Range("A2:L" & Rows.Count).Clear
    Satir = 2

    For X = 2 To S1.Cells(Rows.Count, "AA").End(3).Row
        Set Bul = S1.Range("D:D").Find(S1.Cells(X, "AA"), , , xlWhole, , xlPrevious)
        If Not Bul Is Nothing Then
            Bul.EntireRow.Copy S2.Cells(Satir, 1)
            If WorksheetFunction.CountA(S1.Range("A" & Bul.Row & ":L" & Bul.Row)) <> 12 Then
                Set Bul = S1.Range("D:D").FindPrevious(Bul)
                If Not Bul Is Nothing Then
                    For Y = 1 To 12
                        If S2.Cells(Satir, Y) = "" Then
                            S1.Cells(Bul.Row, Y).Copy S2.Cells(Satir, Y)
                        End If
                    Next
                End If
            End If
            Satir = Satir + 1
        End If
    Next
    
    Set Bul = Nothing
    Set S1 = Nothing
    Set S2 = Nothing
    
    Application.ScreenUpdating = True
    
    MsgBox "İşleminiz tamamlanmıştır.", vbInformation
End Sub