Şartlı veri aktarımı hakkında sorum

[drummers]

Ekli dosyamda 2 sekme bulunmakta. Data sekmesindeki verilerimde işi terk tarihi alanına veri girildiğinde veri girilen satırın yazı karekteri kırmızı olmaktadır. Dosya sekmesindeki " Verileri Aktar" makrosuda data sekmesinden verileri alarak liste oluşturmaktadır.

Benim sorum şudur: Kırmızı renkli verileri yok sayararak dosya sekmesindeki tabloya aktarması ve akratılan veriler arasında satır boşluğu olmaması.

Şimdiden teşekkürler

 

[drummers]

yardım rica edebilirmiyim ?

 

[halit3]

yardım rica edebilirmiyim ?

Bu kodu denermisiniz ?

Sub Aktar()
sat = Worksheets("Dosya").[B65536].End(3).Row + 1
sat1 = Worksheets("Dosya").[G65536].End(3).Row + 1
sat2 = Worksheets("Dosya").[L65536].End(3).Row + 1
sat3 = Worksheets("Dosya").[Q65536].End(3).Row + 1
For i = 2 To WorksheetFunction.CountA(Worksheets("data").Range("B2:B46")) + 2
If Worksheets("data").Cells(i, 17).Value = "" Then
Worksheets("Dosya").Cells(sat, 2).Value = Worksheets("data").Cells(i, 2).Value
Worksheets("Dosya").Cells(sat, 4).Value = Worksheets("data").Cells(i, 17).Value
sat = sat + 1
End If
Next
For i = 47 To WorksheetFunction.CountA(Worksheets("data").Range("B47:B89")) + 47
If Worksheets("data").Cells(i, 17).Value = "" Then
Worksheets("Dosya").Cells(sat1, 7).Value = Worksheets("data").Cells(i, 2).Value
Worksheets("Dosya").Cells(sat1, 9).Value = Worksheets("data").Cells(i, 17).Value
sat1 = sat1 + 1
End If
Next
For i = 90 To WorksheetFunction.CountA(Worksheets("data").Range("B90:B133")) + 90
If Worksheets("data").Cells(i, 17).Value = "" Then
Worksheets("Dosya").Cells(sat2, 12).Value = Worksheets("data").Cells(i, 2).Value
Worksheets("Dosya").Cells(sat2, 14).Value = Worksheets("data").Cells(i, 17).Value
sat2 = sat2 + 1
End If
Next
For i = 134 To WorksheetFunction.CountA(Worksheets("data").Range("B134:B177")) + 134
If Worksheets("data").Cells(i, 17).Value <> "" Then
Worksheets("Dosya").Cells(sat3, 17).Value = Worksheets("data").Cells(i, 2).Value
Worksheets("Dosya").Cells(sat3, 19).Value = Worksheets("data").Cells(i, 17).Value
sat3 = sat3 + 1
End If
Next
End Sub