Kritere göre aktarma kodunda revize

[Korhan Ayhan]

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.

 

[xxrt]

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

 

[Levent Menteşoğlu]

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]

[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]

Selamlar,

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