Kritere göre aktarma kodunda revize

Korhan Ayhan

Administrator
Yönetici
Admin
Katılım
15 Mart 2005
Mesajlar
42,247
Excel Vers. ve Dili
Microsoft 365 Tr-En 64 Bit
Selamlar,

Arkadaşlar ekteki dosyada belirli kriterlere göre aktarım yapmak için kod oluşturdum fakat istediğim gibi çalışmıyor bir yerde yanlışlık yapıyorum çözemedim yardımcı olurmusunuz.

Kriterlerim;

H sütunu 4999 dan büyük ise , I sütunu 14 yada 15 ise , J sütunu 532-533-534-535-536-537-538 ile başlamıyorsa , L sütunu 0 dan büyükse o satırı aktarmasını istiyorum.
 
X

xxrt

Misafir
Kriterler....Başımın belası oldu hep..
Bu işe en iyi levent adapteli..
 

Levent Menteşoğlu

Administrator
Yönetici
Admin
Katılım
13 Ekim 2004
Mesajlar
16,057
Excel Vers. ve Dili
Excel 2010-32 bit-Türkçe
Excel 365 -32 bit-Türkçe
Kodunuzu aşağıdaki gibi düzenleyin.

[vb:1:b7438bf6d8]Sub Aktar()
Set S1 = Sheets("DATA")
Set S2 = Sheets("RAPOR")
Set Birim_Ücret = Sheets("DATA").Range("P1")
S2.[A2:H65536].ClearContents
S1.Select
Y = 0
For X = 1 To [A65536].End(3).Row
Y = S2.[A65536].End(3).Row
Y = Y + 1
If Cells(X, 8) > 4999 And (Cells(X, 9) = 14 Or Cells(X, 9) = 15) Then
If Left(Cells(X, 10), 3) * 1 < 532 Or Left(Cells(X, 10), 3) * 1 > 538 Then
S2.Cells(Y, 1) = Format(S1.Cells(X, 1), "dd.mm.yyyy")
S2.Cells(Y, 2) = Format(S1.Cells(X, 2), "hh:mm:ss")
S2.Cells(Y, 3) = Format(S1.Cells(X, 7), "hh:mm:ss")
S2.Cells(Y, 4) = S1.Cells(X, 8)
S2.Cells(Y, 5) = S1.Cells(X, 9)
S2.Cells(Y, 6) = Format(S1.Cells(X, 10), "(###) ###-####")
S2.Cells(Y, 7) = S1.Cells(X, 12)
S2.Cells(Y, 8) = Format((S2.Cells(Y, 7) * Birim_Ücret), "#,##0.00 YTL") * 1
End If: End If
Next
MsgBox "Abone bilgileri aktarım işlemi tamamlanmıştır.", vbInformation
End Sub
[/vb:1:b7438bf6d8]

Bu işe en iyi Levent adapteli..
Teşekkürler xxrt.
 

veyselemre

Özel Üye
Katılım
9 Mart 2005
Mesajlar
3,646
Excel Vers. ve Dili
Pro Plus 2021
[vb:1:c297db0931]Sub Aktar()
Set S1 = Sheets("DATA")
Set S2 = Sheets("RAPOR")
Set Birim_Ücret = Sheets("DATA").Range("P1")
S2.[A2:H65536].ClearContents
S1.Select
Y = 1
For x = 1 To [A65536].End(3).Row

kod = Val(Left(Cells(x, 10), 3))
If Cells(x, 8) > 4999 And (Cells(x, 9) = 14 Or Cells(x, 9) = 15) And Cells(x, 12) > 0 And Not (kod >= 532 And kod <= 538) Then
Y = Y + 1
S2.Cells(Y, 1) = Format(Cells(x, 1), "dd.mm.yyyy")
S2.Cells(Y, 2) = Format(Cells(x, 2), "hh:mm:ss")
S2.Cells(Y, 3) = Format(Cells(x, 7), "hh:mm:ss")
S2.Cells(Y, 4) = Cells(x, 8)
S2.Cells(Y, 5) = Cells(x, 9)
S2.Cells(Y, 6) = Format(Cells(x, 10), "(###) ###-####")
S2.Cells(Y, 7) = Cells(x, 12)
S2.Cells(Y, 8) = Format((S2.Cells(Y, 7) * Birim_Ücret), "#,##0.00 YTL") * 1
End If
Next x

MsgBox "Abone bilgileri aktarım işlemi tamamlanmıştır.", vbInformation

End Sub[/vb:1:c297db0931]
 

Korhan Ayhan

Administrator
Yönetici
Admin
Katılım
15 Mart 2005
Mesajlar
42,247
Excel Vers. ve Dili
Microsoft 365 Tr-En 64 Bit
Selamlar,

Arkadaşlar ellerinize sağlık iki kodda işimi gördü. :hey:
 
Üst