for next döngü oluşturma

[xternet]

Merhaba Arkadaşlar,
Aşağıdaki kodda "SINIF SEÇME" diye başlayan ve iki kez tekrar eden bir kod var.
Dikkat ederseniz birebir aynı gibi gözüken "SINIF SEÇME" kodlarının 1.sinin ilk satırında [AN18]
2.sinin ilk satırında [AN19] yazmakta.

Benzer şekilde 1.nin sondan 4.satırında Range("W10") ,
2.nin sondan 4.satırında Range("Z10")
yazmakta.

Benim "SINIF SEÇME" kodunun 6 kez tekrarlanmasına ihtiyacım var. Bu tekrarlarda;
ilk satırdaki değişkenin, [AN18], [AN19], [AN20], [AN21], [AN22], [AN23],
sondan 4.satırdaki değişkenin, Range("W10"), Range("Z10"), Range("AC10"), Range("AF10"), Range("AI10"), Range("AL10"),

olmasına ihtiycım var. Bu da For Nex döngüsüyle mümkün sanırım. Böylece "SINIF SEÇME" kodunu 6 kez tekrarlamak yerine bir kez yazarak halletmiş olucam.(Sınıf seçme kodunun aslı, buraya yazdığımdan da daha uzun)

Br şekilde zaman ayıracak arkadaşlara şimdiden teşekkür ederim.

İyi çalışmalar.


'SINIF SEÇME
Selection.AutoFilter Field:=1, Criteria1:=[AN18]
Sheets("RAPOR_OLUSTUR").Select
.
.
.
Sheets("TOPLU_RAPOR").Select
Range("W10").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Sheets("ANAHTAR_CEVAPLAR").Select



'SINIF SEÇME
Selection.AutoFilter Field:=1, Criteria1:=[AN19]
Sheets("RAPOR_OLUSTUR").Select
.
.
.
Sheets("TOPLU_RAPOR").Select
Range("Z10").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False

 

[Orion1]

Dim arr(), sat As Byte
sat = 18
arr = Array("", "W10", "Z10", "AC10", "AF10", "AI10", "AL10")
For i = 1 To 6
    Selection.AutoFilter Field:=1, Criteria1:=Cells(sat, "AN").Value
    Sheets("RAPOR_OLUSTUR").Select
    '......................
    '..................
    '.....................
    Sheets("TOPLU_RAPOR").Select
    Range(arr(i)).Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
    :=False, Transpose:=False
    sat = sat + 1
Next i

 

[xternet]

Sayın Gizlen;
Öncelikle yazdığınız kod için teşekkür ederim. Kod kusursuz çalışıyor.

Yalnız kodun ara satırlarında

    Selection.AutoFilter Field:=1, Criteria1:=Cells(sat, "AN").Value

satırına bağlı olarak yapılan süzme işlemine göre devam eden satırlar var. Burada süzme kriterinin belirlendiği hücre ( Cells(sat, "AN").Value ) boş olduğunda hata mesajı aldım.
Bu gibi durumlarda döngüyü nasıl sonlandırabilirim yada boş hücre için pas geçip diğerlerinden devam edebilirim.

 

[Orion1]

Sayın Gizlen;
Öncelikle yazdığınız kod için teşekkür ederim. Kod kusursuz çalışıyor.

Yalnız kodun ara satırlarında



satırına bağlı olarak yapılan süzme işlemine göre devam eden satırlar var. Burada süzme kriterinin belirlendiği hücre ( Cells(sat, "AN").Value ) boş olduğunda hata mesajı aldım.
Bu gibi durumlarda döngüyü nasıl sonlandırabilirim yada boş hücre için pas geçip diğerlerinden devam edebilirim.

Aşağıdaki gibi deneyiniz.

Dim arr(), sat As Byte
sat = 18
arr = Array("", "W10", "Z10", "AC10", "AF10", "AI10", "AL10")
For i = 1 To 6
   [B][COLOR="Red"] if cells(sat,"AN").value ="" then goto atla [/COLOR][/B]
    Selection.AutoFilter Field:=1, Criteria1:=Cells(sat, "AN").Value
    Sheets("RAPOR_OLUSTUR").Select
    '......................
    '..................
    '.....................
    Sheets("TOPLU_RAPOR").Select
    Range(arr(i)).Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
    :=False, Transpose:=False
[B][COLOR="Red"]atla:    [/COLOR][/B]
    sat = sat + 1
Next i

 

[xternet]

Çok teşekkür ederim Sayın Gizlen.
Zihninize sağlık.
İyi çalışmalar.

 

[Orion1]

Çok teşekkür ederim Sayın Gizlen.
Zihninize sağlık.
İyi çalışmalar.

Rica ederim.
İyi çalışmalar.