Verileri ilgili sayfaya aktarma

[Ömer]

Çalışma sayfası kod bölümüne kopyalayın. Önce #1 numaralı mesaja yazdığınız formülü sayfalardan silersiniz.

Fatura sayfası F sütunu yapılan işlem kodu tetikler.

Private Sub Worksheet_Change(ByVal Target As Range)
 
    Dim syf As Worksheet
 
    If Intersect(Target, Range("F5:F" & Rows.Count)) Is Nothing Then Exit Sub
 
    With Target
 
        Set syf = Sheets("" & Cells(.Row, "C") & "")
        sat = syf.Cells(200, "A").End(xlUp).Row + 1
 
        syf.Cells(sat, "A") = Cells(.Row, "A")
        syf.Cells(sat, "B") = Cells(.Row, "B")
        syf.Cells(sat, "C") = Cells(.Row, "D")
        syf.Cells(sat, "D") = Cells(.Row, "E")
        syf.Cells(sat, "E") = Cells(.Row, "F")
 
    End With
 
End Sub

.

 

[MERDAG]

Ömer Bey ilginize çok teşekkürle ama vermiş olduğunuz kodları çalıştıramadım.
Dosyayı ekledim nerede yanlış yapmışım bir bakabilirmisiniz...

 

[Ömer]

Kodları Fatura sayfasının kod bölümüne yapıştırın.

 

[MERDAG]

Ömer Bey ellerinize sağlık teşekkürler...

Yalnız bir sorum olacak 10.mesajda vermiş olduğunuz koda nasıl bir ekleme yapmak gerekirdi sadece ilgili sayfaları silmesi için...

Birde vermiş olduğunuz son kodda fatura satırında değişiklik yapınca o satırı tekrar aktarıyor.
Aktarma yaparken sayfayı yenilese nasıl olur.

 

[Ömer]

Bence buton ile aktarma yapın. Sadece Pano sayfası ve sayfa adında müşteri geçen sayfalardaki bilgiler silinir.

Sub Sayfalara_Aktar()
 
    Dim syf As String, i As Long, sat As Long
 
    With Application
        .ScreenUpdating = False
        .Calculation = xlManual
    End With
 
    Sheets("FATURA").Select
    On Error Resume Next
 
    For i = 1 To Worksheets.Count
        With Sheets(i)
            If .Name = "PANO" Or .Name Like "*MÜŞTERİ*" Then
                .Range("A10:E200").ClearContents
                [COLOR=red].AutoFilterMode = False[/COLOR]
            End If
        End With
    Next i
 
    For i = 5 To Cells(Rows.Count, "C").End(xlUp).Row
        syf = Cells(i, "C")
        With Sheets(syf)
            sat = .Cells(200, "C").End(xlUp).Row + 1
            .Cells(sat, "A") = Cells(i, "A")
            .Cells(sat, "B") = Cells(i, "B")
            .Cells(sat, "C") = Cells(i, "D")
            .Cells(sat, "D") = Cells(i, "E")
            .Cells(sat, "E") = Cells(i, "F")
        End With
    Next i
 
    MsgBox "Aktarım Tamamlandı.", , "excel.web.tr"
 
     With Application
        .ScreenUpdating = True
        .Calculation = xlAutomatic
    End With
 
End Sub

 

[MERDAG]

Ömer Bey müşteri adları farklı olacağı için (A İNŞAATI, B MAĞAZASI gibi) bu şekilde değilde FATURA sayfası C sütunundaki isimlere ait olan sayfalardaki bilgileri silse olabilirmi...

 

[Ömer]

Silincek sayfaların özeti, Bayiler sayfası B sütunundaki Sayfa adları mı?

 

[MERDAG]

Evet doğrudur...

 

[Ömer]

Evet doğrudur...

Bu şekilde deneyin.

Sub Sayfalara_Aktar()
 
    Dim syf As String, i As Long, sat As Long, Sb As Worksheet, j As Byte
    
    Set Sb = Sheets("BAYİLER")
 
    With Application
        .ScreenUpdating = False
        .Calculation = xlManual
    End With
 
    Sheets("FATURA").Select
    On Error Resume Next
 
    For i = 1 To Worksheets.Count
        With Sheets(i)
            For j = 5 To Sb.Cells(28, "B").End(xlUp).Row
                If .Name = Sb.Cells(j, "B") Then
                    .Range("A10:E200").ClearContents
                End If
            Next j
        End With
    Next i
 
    For i = 5 To Cells(Rows.Count, "C").End(xlUp).Row
        syf = Cells(i, "C")
        With Sheets(syf)
            sat = .Cells(200, "C").End(xlUp).Row + 1
            .Cells(sat, "A") = Cells(i, "A")
            .Cells(sat, "B") = Cells(i, "B")
            .Cells(sat, "C") = Cells(i, "D")
            .Cells(sat, "D") = Cells(i, "E")
            .Cells(sat, "E") = Cells(i, "F")
        End With
    Next i
 
    MsgBox "Aktarım Tamamlandı.", , "excel.web.tr"
 
     With Application
        .ScreenUpdating = True
        .Calculation = xlAutomatic
    End With
 
End Sub

.

 

[MERDAG]

Ömer Bey bir sorum daha olacak
Müşteri sayfalarında

Sub filtre()
ActiveSheet.AutoFilterMode = False
Range("A8:G65536").AutoFilter
Range("A8").AutoFilter field:=1, Criteria1:=">=" & CLng(Range("O1").Value), _
Operator:=xlAnd, field:=1, Criteria2:="<=" & CLng(Range("O2").Value)
End Sub

bu kodla filitreleme yapıyorum. Aktarma işlemine başlamadan bu filitreleme işlemini geçici bir süre nasıl kaldırabiliriz.

 

[Ömer]

Tam olarak anlamadım. #25 numaralı mesajda ilaveyi kırmızı ile işaretledim. İstediğiniz bu mu?

 

[MERDAG]

Ömer Bey öncelikle sabrınız için teşekkürler...
25 nolu mesajda verdiğiniz ilave kodu bir üst satıra yazınca oldu.
Şu anda tam istediğim gibi çalışıyor.
Çok teşekkürler emeğinize sağlık Allah (cc) razı olsun...