Listeden kes yapıştır için makro yardımı.

[KARTAL06]

Yapmak istediğim belli zamanlarda değişen alt alta iki ayrı listeden hücre içeriğine göre bir butona bastığımda diğer sayfaya satırları seçerek kes yapıştır yapacak bir makro yapmak. Ekte bu haftanın listeleri var. Öğlenden bu tarafa makro kaydedici ile yapmaya çalıştım ama olmadı. Aramalardada böyle bir örneğe rastlamadım. İlgilenen arkadaşlara şimdiden teşekkürler.

 

[KARTAL06]

Kimsenin dikkatini çekmedi herhade?

 

[Korhan Ayhan]

Selamlar,

Aşağıdaki kodu denermisiniz.

Sub AKTAR()
    Dim ALAN1 As Range
    Dim ALAN2 As Range
    Set S1 = Sheets("LFPLAN")
    Set S2 = Sheets("LFPLANET")
    S2.[A2:O40].ClearContents
    S2.[A43:O85].ClearContents
    For Each ALAN1 In S1.[A2:A198].SpecialCells(xlCellTypeConstants, 23)
    If ALAN1.Offset(0, 11) = "ET" Then
    SATIR = S2.[A42].End(3).Row + 1
    If SATIR < 42 Then
    S2.Range("A" & SATIR & ":O" & SATIR).Value = S1.Range("A" & ALAN1.Row & ":O" & ALAN1.Row).Value
    S1.Range("A" & ALAN1.Row & ":O" & ALAN1.Row).Value = ""
    End If
    End If
    Next
    S1.[A2:O198].Sort Key1:=[A2], Order1:=xlAscending
    For Each ALAN2 In S1.[A200:A65536].SpecialCells(xlCellTypeConstants, 23)
    If ALAN2.Offset(0, 11) = "ET" Then
    SATIR = S2.[A65536].End(3).Row + 1
    S2.Range("A" & SATIR & ":O" & SATIR).Value = S1.Range("A" & ALAN2.Row & ":O" & ALAN2.Row).Value
    S1.Range("A" & ALAN2.Row & ":O" & ALAN2.Row).Value = ""
    End If
    Next
    S1.[A200:O65536].Sort Key1:=[A200], Order1:=xlAscending
    S2.Select
    Set S1 = Nothing
    Set S2 = Nothing
    MsgBox "&#304;&#351;leminiz tamamlanm&#305;&#351;t&#305;r.", vbInformation
End Sub

 

[KARTAL06]

Kodu soru için gönderdiğim tabloda çalıştırdım

Ama esas dosyada sarı alanı alıyor mavi alanda hata veriyor neden olabilir?
Kendim çalışırken gelişmiş filitre ile alan tanımlamıştım ondan olabilirmi? Birde listede hiç "ET" yoksa da yine hata veriyor.
Esas dosyayı ekledim bakrsanız sevinirim.

 

[Korhan Ayhan]

Selamlar,

LFPLANET sayfasındaki mavi alana ait başlık satırını sildiğiniz için hata veriyordur.

 

[KARTAL06]

Denedim olamadı

Satırı aynı şekilde kopyadım olmadı. Birde listede hiç ete yoksada hata veriyor.

Selamlar,

LFPLANET sayfasındaki mavi alana ait başlık satırını sildiğiniz için hata veriyordur.

 

[Korhan Ayhan]

Selamlar,

En son eklemiş olduğunuz dosya üzerinde vermiş olduğum kodu denedim ve hiç hata ile karşılaşmadım.

 

[KARTAL06]

Acaba ben kodu kopyalarken bir hatamı yapıyorum.

Lfplanet sayfasısda kod sayfasını açıp forumdan kopyala yapıştırla ekliyorum makro çalıştırda sayfa5.aktar olarak görünüyor. lfplanet içinde çalıştır dediğimde MICROSOFT VISUAL BASIC 400 diye bir hata veriyor.Dosya ekte incelermisiniz?

 

[Korhan Ayhan]

Selamlar,

Kodu boş bir modüle ekleyip denermisiniz.

 

[KARTAL06]

Boş modülüde denedim

Selamlar,

Kodu boş bir modüle ekleyip denermisiniz.

Olmuyor beceremedim
"Run-time error'1004' sıralama başvurusu geçerli değil.Sıralamak istediğiniz verilerin içinde olduğundan ve birinci sıralama ölçüt kutusunun aynı veya boş olmadığından emin olun" hatası ile takılıyor.

 

[Korhan Ayhan]

Selamlar,

Ekte örnek dosyanızda gerekli düzenlemeleri yaptım. İncelermisiniz.

 

[KARTAL06]

Çok teşekkür ederim.

Herhalde benim kadar beceriksiz bir çırakla karşılaşmamışsınızdır.
Sizi meşgul ettim ben neden beceremedim anlayamadım ama en kısa zamanda VBA öğrenmek için bir kursa katılmaya çalışacağım. Tabbi işer yakamı bırakırsa.
Emeğinize bilginize sağlık.

 

[KARTAL06]

Merhaba bir modifiye yapabilirmiyiz.

Örnekte lfplanet sayfasına sarı alandaki "et"leri aktardıktan sonra 11 satır sonraya mavi alndaki "et" leri aktarıyor. Bu işemi lfpalandaki sarı alndakileri 40. satıra kadar mavileride 41. satırdan sonra yapıştırmak mümkünmü? Birde ilşeme ilk başlarken önce lfplanet deki alanları bir önceki plandan artık kalmasın diye temizlemek gerekli.

 

[Korhan Ayhan]

Selamlar,

Örnek dosyadaki kodu aşağıdaki şekilde değiştirip denermisiniz.

Sub AKTAR()
    Dim ALAN1 As Range
    Dim ALAN2 As Range
    Set S1 = Sheets("LFPLAN")
    Set S2 = Sheets("LFPLANET")
    Application.Calculation = xlCalculationManual
    S2.[A2:O65536].ClearContents
    SATIR = 2
    For Each ALAN1 In S1.[A2:A198].SpecialCells(xlCellTypeConstants, 23)
    If ALAN1.Offset(0, 11) = "ET" Then
    S2.Range("A" & SATIR & ":O" & SATIR).Value = S1.Range("A" & ALAN1.Row & ":O" & ALAN1.Row).Value
    S1.Range("A" & ALAN1.Row & ":O" & ALAN1.Row).Value = ""
    SATIR = SATIR + 1
    End If
    Next
    S1.[A2:O198].Sort Key1:=[A2], Order1:=xlAscending
    SATIR = 41
    For Each ALAN2 In S1.[A200:A65536].SpecialCells(xlCellTypeConstants, 23)
    If ALAN2.Offset(0, 11) = "ET" Then
    S2.Range("A" & SATIR & ":O" & SATIR).Value = S1.Range("A" & ALAN2.Row & ":O" & ALAN2.Row).Value
    S1.Range("A" & ALAN2.Row & ":O" & ALAN2.Row).Value = ""
    SATIR = SATIR + 1
    End If
    Next
    S1.[A200:O65536].Sort Key1:=[A200], Order1:=xlAscending
    S2.Select
    Set S1 = Nothing
    Set S2 = Nothing
    Application.Calculation = xlCalculationAutomatic
    MsgBox "İşleminiz tamamlanmıştır.", vbInformation
End Sub

 

[KARTAL06]

Hemen denedim ve oldu

Teşekkür ederim süper oldu.