Tarih yoksa yazsın

[igultekin2000]

iyi akşamlar; çalışma sayfasının D hücesindeki gün ve ay olan kısımı A hücresine yazdırıyorum, D hücresinde bazı durumlarda sadece " Açılış, Ödeme " gibi yazı olabiliyor, böyle durumlarda yani D hücresinde sayı değeri olmadığı durumlara 01.01.2019 tarihini makroya eklemek istiyorum. Teşekkürler

Sub rapor() 'tutar listeleme
On Error Resume Next
Application.ScreenUpdating = False: Application.Calculation = xlCalculationManual
Set sl = Sheets("Ana Sayfa"): Set sk = Sheets("BIRIKTIR")
Son = sl.Range("B" & Rows.Count).End(3).Row + 3 'kopyalanacak sayfanın başlangıç satırı
sat = 2
sl.Range("B3:G" & Son).ClearContents
For i = 2 To sk.Range("A" & Rows.Count).End(3).Row 'baz alınan sayfanın listelenecek ürün başlangıç satırı
If sk.Cells(i, "H") > "" Then
sl.Cells(sat, "B") = sk.Cells(i, "B")
sl.Cells(sat, "A") = CDate(Mid(sk.Cells(i, "D"), 1, 5) & "." & 2019)
sl.Cells(sat, "C") = sk.Cells(i, "C")
sl.Cells(sat, "D") = sk.Cells(i, "D")
sl.Cells(sat, "E") = sk.Cells(i, "H")
'sl.Cells(sat, "G") = sk.Cells(i, "D")
'sl.Cells(sat, "H") = sk.Cells(i, "M")

sat = sat + 1
End If
Next i

Application.ScreenUpdating = True: Application.Calculation = xlCalculationAutomatic
End Sub

 

[EmrExcel16]

Deneyin.

Sub rapor() 'tutar listeleme
On Error Resume Next
Application.ScreenUpdating = False: Application.Calculation = xlCalculationManual
Set sl = Sheets("Ana Sayfa"): Set sk = Sheets("BIRIKTIR")
Son = sl.Range("B" & Rows.Count).End(3).Row + 3 'kopyalanacak sayfanın başlangıç satırı
sat = 2
sl.Range("B3:G" & Son).ClearContents
For i = 2 To sk.Range("A" & Rows.Count).End(3).Row 'baz alınan sayfanın listelenecek ürün başlangıç satırı
If sk.Cells(i, "H") > "" Then
sl.Cells(sat, "B") = sk.Cells(i, "B")
If IsDate(Mid(sk.Cells(i, "D"), 1, 5) & "." & 2019) Then
    sl.Cells(sat, "A") = CDate(Mid(sk.Cells(i, "D"), 1, 5) & "." & 2019)
Else
    sl.Cells(sat, "A") = CDate("01.01.2019")
End If
sl.Cells(sat, "C") = sk.Cells(i, "C")
sl.Cells(sat, "D") = sk.Cells(i, "D")
sl.Cells(sat, "E") = sk.Cells(i, "H")
'sl.Cells(sat, "G") = sk.Cells(i, "D")
'sl.Cells(sat, "H") = sk.Cells(i, "M")

sat = sat + 1
End If
Next i

Application.ScreenUpdating = True: Application.Calculation = xlCalculationAutomatic
End Sub

 

[igultekin2000]

Deneyin.

Sub rapor() 'tutar listeleme
On Error Resume Next
Application.ScreenUpdating = False: Application.Calculation = xlCalculationManual
Set sl = Sheets("Ana Sayfa"): Set sk = Sheets("BIRIKTIR")
Son = sl.Range("B" & Rows.Count).End(3).Row + 3 'kopyalanacak sayfanın başlangıç satırı
sat = 2
sl.Range("B3:G" & Son).ClearContents
For i = 2 To sk.Range("A" & Rows.Count).End(3).Row 'baz alınan sayfanın listelenecek ürün başlangıç satırı
If sk.Cells(i, "H") > "" Then
sl.Cells(sat, "B") = sk.Cells(i, "B")
If IsDate(Mid(sk.Cells(i, "D"), 1, 5) & "." & 2019) Then
    sl.Cells(sat, "A") = CDate(Mid(sk.Cells(i, "D"), 1, 5) & "." & 2019)
Else
    sl.Cells(sat, "A") = CDate("01.01.2019")
End If
sl.Cells(sat, "C") = sk.Cells(i, "C")
sl.Cells(sat, "D") = sk.Cells(i, "D")
sl.Cells(sat, "E") = sk.Cells(i, "H")
'sl.Cells(sat, "G") = sk.Cells(i, "D")
'sl.Cells(sat, "H") = sk.Cells(i, "M")

sat = sat + 1
End If
Next i

Application.ScreenUpdating = True: Application.Calculation = xlCalculationAutomatic
End Sub

teşekkür ederim elinize sağlık , sorunsuz çalışıyor, iyi çalışmalar

 

[EmrExcel16]

teşekkür ederim elinize sağlık , sorunsuz çalışıyor, iyi çalışmalar

Rica ederim , iyi çalışmalar.