bu kodları nasıl kısaltabiliriz

[cairotaner]

arkadaşlar, aşağıya yazmış olduğum kodları nasıl kısaltabiliriz. bu kodları her satır için yazmam mümkün değil. yaklaşık olarak 5000 satır var

Sub BULAKTAR()

Set S1 = Sheets("1")
Set S2 = Sheets("SONUC")

SATIR = 1


For A = S2.[C2] To S2.[X2]
If A = S2.[AH1] Then
S1.Cells(SATIR, 1) = S2.[C2]
S1.Cells(SATIR, 2) = S2.[D2]
S1.Cells(SATIR, 3) = S2.[E2]
S1.Cells(SATIR, 4) = S2.[F2]
S1.Cells(SATIR, 5) = S2.[G2]
S1.Cells(SATIR, 6) = S2.[H2]
S1.Cells(SATIR, 7) = S2.[I2]
S1.Cells(SATIR, 8) = S2.[J2]
S1.Cells(SATIR, 9) = S2.[K2]
S1.Cells(SATIR, 10) = S2.[L2]
S1.Cells(SATIR, 11) = S2.[M2]
S1.Cells(SATIR, 12) = S2.[N2]
S1.Cells(SATIR, 13) = S2.[O2]
S1.Cells(SATIR, 14) = S2.[P2]
S1.Cells(SATIR, 15) = S2.[Q2]
S1.Cells(SATIR, 16) = S2.[R2]
S1.Cells(SATIR, 17) = S2.[S2]
S1.Cells(SATIR, 18) = S2.[T2]
S1.Cells(SATIR, 19) = S2.[U2]
S1.Cells(SATIR, 20) = S2.[V2]
S1.Cells(SATIR, 21) = S2.[W2]
S1.Cells(SATIR, 22) = S2.[X2]
End If
Next
SATIR = SATIR + 1
For B = S2.[C3] To S2.[X3]
If B = S2.[AH1] Then
S1.Cells(SATIR, 1) = S2.[C3]
S1.Cells(SATIR, 2) = S2.[D3]
S1.Cells(SATIR, 3) = S2.[E3]
S1.Cells(SATIR, 4) = S2.[F3]
S1.Cells(SATIR, 5) = S2.[G3]
S1.Cells(SATIR, 6) = S2.[H3]
S1.Cells(SATIR, 7) = S2.[I3]
S1.Cells(SATIR, 8) = S2.[J3]
S1.Cells(SATIR, 9) = S2.[K3]
S1.Cells(SATIR, 10) = S2.[L3]
S1.Cells(SATIR, 11) = S2.[M3]
S1.Cells(SATIR, 12) = S2.[N3]
S1.Cells(SATIR, 13) = S2.[O3]
S1.Cells(SATIR, 14) = S2.[P3]
S1.Cells(SATIR, 15) = S2.[Q3]
S1.Cells(SATIR, 16) = S2.[R3]
S1.Cells(SATIR, 17) = S2.[S3]
S1.Cells(SATIR, 18) = S2.[T3]
S1.Cells(SATIR, 19) = S2.[U3]
S1.Cells(SATIR, 20) = S2.[V3]
S1.Cells(SATIR, 21) = S2.[W3]
S1.Cells(SATIR, 22) = S2.[X3]
End If
Next

End Sub

bizlerden yardımlarını esirgemeyen arkadaşlara şimdiden teşekkür ederim.

 

[ozgretmen]

Aşağıdaki şekilde dener misiniz ?

Sub BULAKTAR()
For a = Sheets("SONUC").[C2] To Sheets("SONUC").[X2]
If a = Sheets("SONUC").[AH1] Then
Worksheets("SONUÇ").Range("C2:X2").Copy Worksheets("1").Range("A1")
End If
Next a
For B = Sheets("SONUC").[C3] To Sheets("SONUC").[X3]
If B = Sheets("SONUC").[AH1] Then
Worksheets("SONUÇ").Range("C3:X3").Copy Worksheets("1").Range("A2")
End If
Next B
End Sub

 

[cairotaner]

Sevgili Ozgretmen,
vermiş olduğunuz kodlar 2 satır için güzel çalışıyor. teşekkür ederim
ancak ben 5000 satır olan bir sayfa üzerinde çalışmak istiyorum.
bu kodları 5000 satıra kadar nasıl genişletebiliriz.

 

[ozgretmen]

Aşağıdaki şekilde dener misiniz ? Deneme fırsatım olmadı.Eğer dosaynızı eklerseniz daha TAM sonuç verilebilir.İyi çalışmalar...

Sub BULAKTAR()
For i = 2 To 5000
For a = Sheets("SONUC").[C2] To Sheets("SONUC").[X2]
If a = Sheets("SONUC").[AH1] Then
Worksheets("SONUÇ").Range("C" & i & ":" & "X" & i).Copy Worksheets("1").Range("A" & i - 1)
End If
Next a
For b = Sheets("SONUC").[C3] To Sheets("SONUC").[X3]
If b = Sheets("SONUC").[AH1] Then
Worksheets("SONUÇ").Range("C3:X3").Copy Worksheets("1").Range("A2")
Worksheets("SONUÇ").Range("C" & i + 1 & ":" & "X" & i + 1).Copy Worksheets("1").Range("A" & i)
End If
Next b
Next i
End Sub

 

[cairotaner]

sevgili özgretmen,
sanırım kendimi ifade edemedim.
ayrıca örnek dosyayı baştan eklememekle hata ettim.
istediğiniz örnek dosya ekte.
örnekte detaylı olarak açıkladım.
ayrıca vermiş olduğunuz diğer kodları da diğer çalışmalarımda kullanabileceğimi sanıyorum.
teşekkür ederim.

 

[leumruk]

Sub Dene3()
Sat = [X65536].End(3).Row
Set c = [c1]
Set x = Cells(Sat, "x")
For Each i In Range(c, x)
If i = [AH1] Then
Son = [1!c65536].End(3).Row
  Range(Cells(i.Row, 3), Cells(i.Row, 22)).Copy Sheets("1").Cells(Son + 1, "c")
End If
Next
End Sub

Bu kodu dener misiniz?

 

[leumruk]

Eklediğim kodda küçük bir değişiklik yaptım. Bu şekilde daha sağlıklı olacaktır. Öteki türlü satırı komple aktarıyordu; bu şekilde geçerli aralığı aktaracaktır.
Saygılar...

 

[ozgretmen]

Alternatif olarak aşağıdaki kodu da kullanabilirsiniz .

Sub aktar()
For i = 1 To [C65536].End(3).Row
For j = 3 To 24
If Cells(i, j) = [AH1] Then
m = Sheets("1").[C65536].End(3).Row
Range("C" & i & ":" & "X" & i).Copy Sheets("1").Cells(m + 1, 3)
End If
Next j
Next i
End Sub

 

[cairotaner]

Sn leumruk,
çok teşekkür ederim. vermiş olduğunuz kodlar
benim yapmak istediğime çok yakın. artık biraz da ben
üzerinde uğraşarak sonuca ulaşmaya çalışacağım.
eksik kalan kısım (daha doğrusu fazlalık) aktarımı yaparken
[c:x] arasını değilde tüm satırı baştan sona aktarıyor.
herhalde çözerim. çözemezsem tekrar size başvurabilirim.
yardımlarınız için çok teşekkür ederim.

 

[cairotaner]

ben de son mesajınızı görmeden size cevap yazmıştım.
ellerinize sağlık. çok çok teşekkür ederim.
ayrıca sayın özgertmen arkadaşıma da teşekkür ederim

 

[leumruk]

ben de son mesajınızı görmeden size cevap yazmıştım.
ellerinize sağlık. çok çok teşekkür ederim.
ayrıca sayın özgertmen arkadaşıma da teşekkür ederim

Rica ederim. İyi çalışmalar.