Kopyalanarak aktarılan satırı silme

Erdinç FIRTINA · 19 Şubat 2008

Değerli üyeler,
Aşağıdaki kodlarla, belirlenen kriterlere göre veri sayfasından alınan veriler, tanımlanan sayfalardaki belirlenen alanlara aktarılıyor.
Aktarılan verilerden bazılarının veri sayfasından satırı ile birlikte silinmesini gerekiyor.

Örneğin;
"2" kriterine göre kopyalanarak 'AYŞE' sayfasına aktarılan VERİ sayfasındaki satırlarının da silinmesi mümkün müdür? Bunun;

Range("A1").AutoFilter Field:=2, Criteria1:="1"
Rows.Delete
Range("A1").CurrentRegion.Copy SA.[K1]

şeklinde olabileceğini düşünerek bu şekilde düzenledim. Ancak istediğim olmadı. Acaba bu mümkün değil midir? Kodlarda nasıl bir değişiklik yapmalıyım?

Sub AKTAR()
Application.ScreenUpdating = False
Set SVV = Sheets("Veri")
Set SA = Sheets("ALİ")
Set SB = Sheets("VELİ")
Set SC = Sheets("AYŞE")
SA.[K:Q].Clear
SB.[K:Q].Clear
SC.[K:Q].Clear
SVV.Select
Range("A1").Select
Range("A1").AutoFilter Field:=2, Criteria1:="1"
Range("A1").CurrentRegion.Copy SA.[K1]
Range("A1").AutoFilter Field:=2, Criteria1:="2"
Range("A1").CurrentRegion.Copy SB.[K1]
Range("A1").AutoFilter Field:=2, Criteria1:="3"
Range("A1").CurrentRegion.Copy SC.[K1]
Set SV = Nothing
Set SA = Nothing
Set SB = Nothing
Set SC = Nothing
Application.ScreenUpdating = True
MsgBox "AKTARIM İŞLEMİ TAMAMLANMIŞTIR.", vbInformation
End Sub

Korhan Ayhan · 19 Şubat 2008

Selamlar,

2 kriteri için kullandığınız koda kırmızı renkli satırı ekledim. Diğer kriterler için aynı satırı çoğaltarak kullanabilirsiniz.

Kod:

Sub AKTAR()
    Application.ScreenUpdating = False
    Set SVV = Sheets("Veri")
    Set SA = Sheets("1-AL&#304;")
    Set SB = Sheets("2-VEL&#304;")
    Set SC = Sheets("3-AY&#350;E")
    Set SD = Sheets("10-AHMET")
    SA.[K:Q].Clear
    SB.[K:Q].Clear
    SC.[K:Q].Clear
    SD.[K:Q].Clear
    SVV.Select
    SATIR = [A65536].End(3).Row
    Range("A1").Select
    Range("A1").AutoFilter Field:=2, Criteria1:="1"
    Range("A1").CurrentRegion.Copy SA.[K1]
    Range("A1").AutoFilter Field:=2, Criteria1:="2"
    Range("A1").CurrentRegion.Copy SB.[K1]
    [B][COLOR=red]Range("A2:IV" & SATIR).SpecialCells(xlCellTypeVisible).Delete[/COLOR][/B]
    Range("A1").AutoFilter Field:=2, Criteria1:="3"
    Range("A1").CurrentRegion.Copy SC.[K1]
    Range("A1").AutoFilter Field:=2, Criteria1:="10"
    Range("A1").CurrentRegion.Copy SD.[K1]
    Set SV = Nothing
    Set SA = Nothing
    Set SB = Nothing
    Set SC = Nothing
    Set SD = Nothing
    Application.ScreenUpdating = True
    MsgBox "AKTARIM &#304;&#350;LEM&#304; TAMAMLANMI&#350;TIR.", vbInformation
End Sub

Erdinç FIRTINA · 19 Şubat 2008

Sayın Korhan Ayhan,
Yardımlarınız için çok çok teşekkür ederim!!!

Erdinç FIRTINA · 19 Şubat 2008

Değerli Üyeler,
Sayın Korhan Ayhan satırları silerek aktarma konusunda yardımcı oldu ve kodlar çalışıyor.

Aktarılan verilere sıra numarası vermek için kodlarda ne gibi bir değişiklik yapılmalıdır?

Yardımlarınız için şimdiden çok teşekkürler!!!

Korhan Ayhan · 20 Şubat 2008

Selamlar,

Kullandığınız kodu aşağıdaki şekilde değiştirip denermisiniz.

Kod:

Sub AKTAR()
    Application.ScreenUpdating = False
    Set SVV = Sheets("Veri")
    Set SA = Sheets("1-AL&#304;")
    Set SB = Sheets("2-VEL&#304;")
    Set SC = Sheets("3-AY&#350;E")
    Set SD = Sheets("10-AHMET")
    SA.[K:Q].Clear
    SB.[K:Q].Clear
    SC.[K:Q].Clear
    SD.[K:Q].Clear
    SVV.Select
    SATIR = [A65536].End(3).Row
    Range("A1").Select
    Range("A1").AutoFilter Field:=2, Criteria1:="1"
    Range("A1").CurrentRegion.Copy SA.[K1]
    If SA.[K2] <> "" Then
    For X = 2 To SA.[K65536].End(3).Row
    SA.Cells(X, "K") = X - 1
    Next
    End If
    Range("A1").AutoFilter Field:=2, Criteria1:="2"
    Range("A1").CurrentRegion.Copy SB.[K1]
    If SB.[K2] <> "" Then
    For X = 2 To SB.[K65536].End(3).Row
    SB.Cells(X, "K") = X - 1
    Next
    End If
    On Error GoTo Devam
    Range("A2:IV" & SATIR).SpecialCells(xlCellTypeVisible).Delete
Devam:
    Range("A1").AutoFilter Field:=2, Criteria1:="3"
    Range("A1").CurrentRegion.Copy SC.[K1]
    If SC.[K2] <> "" Then
    For X = 2 To SC.[K65536].End(3).Row
    SC.Cells(X, "K") = X - 1
    Next
    End If
    Range("A1").AutoFilter Field:=2, Criteria1:="10"
    Range("A1").CurrentRegion.Copy SD.[K1]
    If SD.[K2] <> "" Then
    For X = 2 To SD.[K65536].End(3).Row
    SD.Cells(X, "K") = X - 1
    Next
    End If
    Set SV = Nothing
    Set SA = Nothing
    Set SB = Nothing
    Set SC = Nothing
    Set SD = Nothing
    Application.ScreenUpdating = True
    MsgBox "AKTARIM &#304;&#350;LEM&#304; TAMAMLANMI&#350;TIR.", vbInformation
End Sub

Erdinç FIRTINA · 20 Şubat 2008

Sayın Korhan Ayhan,
Size çok teşekkür ederim. Ancak, kodları dosyama uyarladığımda SİLMEK istediğim kritere ait satırları silme işlemi gerçekleşmiyor. Dosyam ekte. Bir bakabilirseniz çok mutlu olurum.
Yardımlarınız için şimdiden çok teşekkürler.

Korhan Ayhan · 20 Şubat 2008

Selamlar,

SATIR isimli değişkeni kod içinde tanımlamayı unuttuğunuz için silme işlemi gerçekleşmiyor.

Aşağıdaki kodu denermisiniz.

Kod:

Sub AKTAR()
    Application.ScreenUpdating = False
    Set SVV = Sheets("&#214;&#286;RENC&#304;B&#304;LG&#304;LER&#304;")
    Set SA = Sheets("AA")
    Set SB = Sheets("AB")
    Set SC = Sheets("AC")
    Set SD = Sheets("AD")
    Set SE = Sheets("AE")
    Set SF = Sheets("AF")
    Set SG = Sheets("AG")
    Set Sh = Sheets("AH")
    Set SI = Sheets("AI")
    Set SJ = Sheets("AJ")
    Set SK = Sheets("AK")
    Set SL = Sheets("AL")
    Set SM = Sheets("AM")
    SA.[B:BK].Clear
    SB.[B:BK].Clear
    SC.[B:BK].Clear
    SD.[B:BK].Clear
    SE.[B:BK].Clear
    SF.[B:BK].Clear
    SG.[B:BK].Clear
    Sh.[B:BK].Clear
    SI.[B:BK].Clear
    SJ.[B:BK].Clear
    SK.[B:BK].Clear
    SL.[B:BK].Clear
    SM.[B:BK].Clear
    
    SVV.Select
    Range("A1").Select
    Range("A1").AutoFilter Field:=63, Criteria1:="AA"
    Range("A1").CurrentRegion.Copy SA.[B1]
    If SA.[B2] <> "" Then
    For X = 2 To SA.[B65536].End(3).Row
    SA.Cells(X, "B") = X - 1
    Next
    End If
    
    Range("A1").AutoFilter Field:=63, Criteria1:="AB"
    Range("A1").CurrentRegion.Copy SB.[B1]
    If SB.[B2] <> "" Then
    For X = 2 To SB.[B65536].End(3).Row
    SB.Cells(X, "B") = X - 1
    Next
    End If
    
    Range("A1").AutoFilter Field:=63, Criteria1:="AC"
    Range("A1").CurrentRegion.Copy SC.[B1]
    If SC.[B2] <> "" Then
    For X = 2 To SC.[B65536].End(3).Row
    SC.Cells(X, "B") = X - 1
    Next
    End If
    
    Range("A1").AutoFilter Field:=63, Criteria1:="AD"
    Range("A1").CurrentRegion.Copy SD.[B1]
    If SD.[B2] <> "" Then
    For X = 2 To SD.[B65536].End(3).Row
    SD.Cells(X, "B") = X - 1
    Next
    End If
    
    Range("A1").AutoFilter Field:=63, Criteria1:="AE"
    Range("A1").CurrentRegion.Copy SE.[B1]
    If SE.[B2] <> "" Then
    For X = 2 To SE.[B65536].End(3).Row
    SE.Cells(X, "B") = X - 1
    Next
    End If
    
    Range("A1").AutoFilter Field:=63, Criteria1:="AF"
    Range("A1").CurrentRegion.Copy SF.[B1]
    If SF.[B2] <> "" Then
    For X = 2 To SF.[B65536].End(3).Row
    SF.Cells(X, "B") = X - 1
    Next
    End If
    
    Range("A1").AutoFilter Field:=63, Criteria1:="AG"
    Range("A1").CurrentRegion.Copy SG.[B1]
    If SG.[B2] <> "" Then
    For X = 2 To SG.[B65536].End(3).Row
    SG.Cells(X, "B") = X - 1
    Next
    End If
    
    Range("A1").AutoFilter Field:=63, Criteria1:="AH"
    Range("A1").CurrentRegion.Copy Sh.[B1]
    If Sh.[B2] <> "" Then
    For X = 2 To Sh.[B65536].End(3).Row
    Sh.Cells(X, "B") = X - 1
    Next
    End If
    Range("A1").AutoFilter Field:=63, Criteria1:="AI"
    Range("A1").CurrentRegion.Copy SI.[B1]
    If SI.[B2] <> "" Then
    For X = 2 To SI.[B65536].End(3).Row
    SI.Cells(X, "B") = X - 1
    Next
    End If
    
    Range("A1").AutoFilter Field:=63, Criteria1:="AJ"
    Range("A1").CurrentRegion.Copy SJ.[B1]
    If SJ.[B2] <> "" Then
    For X = 2 To SJ.[B65536].End(3).Row
    SJ.Cells(X, "B") = X - 1
    Next
    End If
    
    Range("A1").AutoFilter Field:=63, Criteria1:="AK"
    Range("A1").CurrentRegion.Copy SK.[B1]
    If SK.[B2] <> "" Then
    For X = 2 To SK.[B65536].End(3).Row
    SK.Cells(X, "B") = X - 1
    Next
    End If
    Range("A1").AutoFilter Field:=63, Criteria1:="AL"
    Range("A1").CurrentRegion.Copy SL.[B1]
    If SL.[B2] <> "" Then
    For X = 2 To SL.[B65536].End(3).Row
    SL.Cells(X, "B") = X - 1
    Next
    End If
    If [A65536].End(3).Row > 1 Then
    Range("A2:IV" & [A65536].End(3).Row).SpecialCells(xlCellTypeVisible).Delete
    End If
    
    Range("A1").AutoFilter Field:=63, Criteria1:="AM"
    Range("A1").CurrentRegion.Copy SM.[B1]
    If SM.[B2] <> "" Then
    For X = 2 To SM.[B65536].End(3).Row
    SM.Cells(X, "B") = X - 1
    Next
    End If
    
    Range("A1").AutoFilter
    Set SV = Nothing
    Set SA = Nothing
    Set SB = Nothing
    Set SC = Nothing
    Set SD = Nothing
    Set SE = Nothing
    Set SF = Nothing
    Set SG = Nothing
    Set Sh = Nothing
    Set SI = Nothing
    Set SJ = Nothing
    Set SK = Nothing
    Set SL = Nothing
    Set SM = Nothing
    Application.ScreenUpdating = True
    MsgBox "AKTARIM &#304;&#350;LEM&#304; TAMAMLANMI&#350;TIR.", vbInformation
End Sub

Erdinç FIRTINA · 21 Şubat 2008

Sayın Korhan Ayhan,
Size çok ama çok teşekkür ederim. Elinize, yüreğinize ve beyninize sağlık. Her şey için çok sağolun.

Kopyalanarak aktarılan satırı silme

Erdinç FIRTINA

Korhan Ayhan

Administrator

Erdinç FIRTINA

Erdinç FIRTINA

Korhan Ayhan

Administrator

Erdinç FIRTINA

Korhan Ayhan

Administrator

Erdinç FIRTINA