Makroda tekrar eden satırlar...

[aliakgul]

Range("b6:d25").Select
Selection.ClearContents
Range("c6").Value = Sheets("nç1").Range("d1")
For I = 2 To Worksheets("nç1").Cells(10000, 1).End(xlUp).Row
If Worksheets("fiş-1").Range("c6").Value = Sheets("nç1").Cells(I, 3) Then
j = j + 1
Sheets("fiş-1").Cells(j, 2) = Sheets("nç1").Cells(I, 2)
Sheets("fiş-1").Cells(j, 3) = Sheets("nç1").Cells(I, 3)
Sheets("fiş-1").Cells(j, 4) = Sheets("nç1").Cells(I, 4)
. .
. .
. .
Sheets("fiş-1").Cells(j, 168) = Sheets("nç1").Cells(I, 168)

End If

Herkese merhaba,
Arkadaşlar, yukarıdaki çalışmada
"Sheets("fiş-1").Cells(j, 4) = Sheets("nç1").Cells(I, 4)"
biçimli satırlar 168'e kadar devam ediyor. Yani aynı satırı 168 kere tekrar etmem gerekiyor.
Bu tekrarlamayı dizi oluşturmaya benzer bir mantıkla kısaltmanın yolu yok mu?
Şimdiden teşekkürlerimle...

 

[Levent Menteşoğlu]

İşte döngüler bu tip işlemleri kısaltmak için vardır.

Range("b6:d25").Select
Selection.ClearContents
Range("c6").Value = Sheets("nç1").Range("d1")
For I = 2 To Worksheets("nç1").Cells(10000, 1).End(xlUp).Row
If Worksheets("fiş-1").Range("c6").Value = Sheets("nç1").Cells(I, 3) Then
j = j + 1
[B][COLOR=blue]for a=2 to 168
Sheets("fiş-1").Cells(j, a) = Sheets("nç1").Cells(I, a)
next
[/COLOR][/B]End If

 

[aliakgul]

Sayın Leventm, teşekkür ederim, ellerinize sağlık.
Evet haklısınız; döngüler bu tip işlemleri kısaltmak için. Ancak işin püf noktası ise ustalıkta ....
Tam istediğim gibi oldu ancak bu noktada yeni bir sıkıntı oluştu:
Aktarmayı yaparken çok bekliyor..Daha doğrusu işlem çok yavaş ilerliyor. Bu konuda birşey yapabilir miyiz?

 

[Levent Menteşoğlu]

Aslında aynı işlem döngüsüzde yapılabilir. Aşağıdaki iki ayrı uygulama daha öneriyorum. İkincisi çok daha hızlı çalışacaktır.

1.yol

[LEFT]Range("b6:d25").Select
Selection.ClearContents
Range("c6").Value = Sheets("nç1").Range("d1")
For I = 2 To Worksheets("nç1").Cells(10000, 1).End(xlUp).Row
If Worksheets("fiş-1").Range("c6").Value = Sheets("nç1").Cells(I, 3) Then
j = j + 1
[B][COLOR=blue]Sheets("fiş-1").range(Cells(j, 2),cells(j,168)) = Sheets("nç1").range(Cells(I, 2),cells(I,168)).value[/COLOR][/B]
End If[/LEFT]

2. yol copy-paste

[LEFT]Range("b6:d25").Select
Selection.ClearContents
Range("c6").Value = Sheets("nç1").Range("d1")
For I = 2 To Worksheets("nç1").Cells(10000, 1).End(xlUp).Row
If Worksheets("fiş-1").Range("c6").Value = Sheets("nç1").Cells(I, 3) Then
j = j + 1
[COLOR=blue][B]Sheets("nç1").range(Cells(I, 2),cells(I,168)).copy[/B][/COLOR]
[B][COLOR=blue]Sheets("fiş-1").Cells(j, 2).pastespecial[/COLOR][/B]
[B][COLOR=#0000ff]application.cutcopymode=false[/COLOR][/B]
End If[/LEFT]

 

[aliakgul]

Sayın Leventm,
Verdiğiniz her iki uygulamayı da denedim ancak olumsuz sonuç aldım.(Hata veriyor). Belgeyi ekliyorum.

 

[Levent Menteşoğlu]

Aşağıdaki kodu deneyin.

Sub fiş_1_aktar()
Set s1 = Sheets("fiş-1")
Set s2 = Sheets("nç1")
j = 5
s1.Select
s1.Range("b6:d25").ClearContents
s1.Range("c6").Value = s2.Range("d1")
For I = 2 To s2.Cells(65536, 1).End(xlUp).Row
If s1.Range("c6").Value = s2.Cells(I, 3) Then
j = j + 1
s1.Range(s1.Cells(j, "b"), s1.Cells(j, "em")) = s2.Range(s2.Cells(I, "b"), s2.Cells(I, "em")).Value
End If
Next
End Sub

 

[aliakgul]

Teşekkür ederim, sanırım bu işimi sorunsuz yapacak gibi... Tüm ayrıntılarıyla denedikten sonra size sonucu tekrar bildiririm. Ellerinize sağlık, sağolun...