süz aktar kodunda yardım.

[kemal turan]

Merhaba,
Aşağıdaki kodumuz gelen siparişleri süzerek gelen sayfasına aktarıyor.
İsteğim;
Sheets("sipariş").Select satınıdan sonra
Sipariş sahifesinden aktarılan satırların komple silecek kod hususunda yardımlarınızı bekliyorum
Teşekkür ederim

Sub aktarsiparis()
Worksheets("gelen").AutoFilterMode = False
Set S1 = Sheets("sipariş")
Set S2 = Sheets("gelen")
Range("a1").AutoFilter
Range("a1").AutoFilter Field:=1, Criteria1:=">=" & CLng(Range("p1").Value), _
Operator:=xlAnd, Field:=1, Criteria2:="<=" & CLng(Range("q1").Value)

Worksheets("gelen").AutoFilterMode = False
For i = 2 To S1.Range("A65536").End(3).Row
SONSTR = S2.Range("A65536").End(3).Row + 1
If S1.Cells(i, 1).EntireRow.Hidden = False Then
S2.Cells(SONSTR, 1).Value = S1.Cells(i, 1).Value
S2.Cells(SONSTR, 2).Value = S1.Cells(i, 2).Value
S2.Cells(SONSTR, 3).Value = S1.Cells(i, 3).Value
S2.Cells(SONSTR, 4).Value = S1.Cells(i, 4).Value
S2.Cells(SONSTR, 5).Value = S1.Cells(i, 5).Value
S2.Cells(SONSTR, 6).Value = S1.Cells(i, 6).Value
S2.Cells(SONSTR, 7).Value = S1.Cells(i, 7).Value
S2.Cells(SONSTR, 8).Value = S1.Cells(i, 8).Value
S2.Cells(SONSTR, 9).Value = S1.Cells(i, 9).Value
End If
Next
Range("C65536").End(xlUp).Offset(1, 0).Select
Sheets("gelen").Select

MsgBox "Kayıt işlemi tamamlanmıştır.", , "AKSAY EV CONCEPT"
Sheets("sipariş").Select

End Sub

 

[Korhan Ayhan]

Merhaba,,

Foruma kod eklerken lütfen CODE tagını kullanınız. Mesaj yazdığınız pencerede ki # sembolüne basarak bu tagı ekleyebilirsiniz. Böylece yazdığınız mesajlar daha okunaklı görünecektir.

Aşağıdaki kodu deneyiniz.

Sub aktarsiparis()
    Dim Alan As Range
    
    Set S1 = Sheets("sipariş")
    Set S2 = Sheets("gelen")
    
    Range("a1").AutoFilter
    Range("a1").AutoFilter Field:=1, Criteria1:=">=" & CLng(Range("p1").Value), _
    Operator:=xlAnd, Field:=1, Criteria2:="<=" & CLng(Range("q1").Value)
    
    Worksheets("gelen").AutoFilterMode = False
    For i = 2 To S1.Range("A65536").End(3).Row
        SONSTR = S2.Range("A65536").End(3).Row + 1
        If S1.Cells(i, 1).EntireRow.Hidden = False Then
            S2.Cells(SONSTR, 1).Value = S1.Cells(i, 1).Value
            S2.Cells(SONSTR, 2).Value = S1.Cells(i, 2).Value
            S2.Cells(SONSTR, 3).Value = S1.Cells(i, 3).Value
            S2.Cells(SONSTR, 4).Value = S1.Cells(i, 4).Value
            S2.Cells(SONSTR, 5).Value = S1.Cells(i, 5).Value
            S2.Cells(SONSTR, 6).Value = S1.Cells(i, 6).Value
            S2.Cells(SONSTR, 7).Value = S1.Cells(i, 7).Value
            S2.Cells(SONSTR, 8).Value = S1.Cells(i, 8).Value
            S2.Cells(SONSTR, 9).Value = S1.Cells(i, 9).Value
            If Alan Is Nothing Then
                Set Alan = S1.Cells(i, 1)
            Else
                Set Alan = Union(Alan, S1.Cells(i, 1))
            End If
        End If
    Next

    Range("C65536").End(xlUp).Offset(1, 0).Select
    Sheets("gelen").Select
    
    MsgBox "Kayıt işlemi tamamlanmıştır.", , "AKSAY EV CONCEPT"

    Sheets("sipariş").Select
    If Not Alan Is Nothing Then Alan.EntireRow.Delete
End Sub

 

[kemal turan]

Korhan bey,
Çok teşekkür ederim.
Selametle kalınız