Dolu sütun kontrolune göre tarih atma

[Ridan]

Merhaba,

Aşağıdaki kod ile FATURA sayfasından ARŞİV sayfasına veri aktarma yapıyorum. İstediğim, aktarılan veri kadar ARŞİV sayfasında K sütununa da günün tarihini yazsın.

Sub aktar2()
Dim s As Integer
Dim sat As Integer
Dim alan As Range
sat = Sheets("ARŞİV").Cells(Rows.Count, "B").End(xlUp).Offset(1, 0).Row
son = Sheets("FATURA").Cells(Rows.Count, "B").End(3).Row

If son > 502 Then son = 502
For s = 3 To son Step 1
If Sheets("FATURA").Cells(s, "B") <> "" Then
    If alan Is Nothing Then
        Set alan = Sheets("FATURA").Range("B" & s & ":H" & s & ",M" & s & ",N" & s)
    Else
        Set alan = Union(alan, Sheets("FATURA").Range("B" & s & ":H" & s & ",M" & s & ",N" & s))
    End If
End If
Next s

On Error Resume Next    ' Eğer sayfada hiç kayıt yoksa alttaki satır hata veriyor
alan.Copy
Sheets("ARŞİV").Range("B" & sat).PasteSpecial xlPasteValues
End Sub

 

[Orion1]

Alttaki kodları deneyiniz.

Sub aktar2()
Dim s As Integer
Dim sat As Integer
Dim alan As Range
[B][COLOR="Red"]Dim sh As Worksheet, sat2 As Long[/COLOR][/B]
sat = Sheets("ARŞİV").Cells(Rows.Count, "B").End(xlUp).Offset(1, 0).Row
son = Sheets("FATURA").Cells(Rows.Count, "B").End(3).Row
[B][COLOR="red"]Set sh = Sheets("ARŞİV")
sat2 = sh.Cells(Rows.Count, "B").End(xlUp).Row + 1[/COLOR][/B]
If son > 502 Then son = 502
For s = 3 To son Step 1
If Sheets("FATURA").Cells(s, "B") <> "" Then
    If alan Is Nothing Then
        Set alan = Sheets("FATURA").Range("B" & s & ":H" & s & ",M" & s & ",N" & s)
        [B][COLOR="red"]sh.Cells(sat2, "K").Value = Date
        sat2 = sat2 + 1[/COLOR][/B]
    Else
        Set alan = Union(alan, Sheets("FATURA").Range("B" & s & ":H" & s & ",M" & s & ",N" & s))
       [B][COLOR="red"] sh.Cells(sat2, "K").Value = Date
        sat2 = sat2 + 1[/COLOR][/B]
    End If
End If
Next s

On Error Resume Next    ' Eğer sayfada hiç kayıt yoksa alttaki satır hata veriyor
alan.Copy
Sheets("ARŞİV").Range("B" & sat).PasteSpecial xlPasteValues
End Sub

 

[Ridan]

Çok teşekkürler evren bey..

 

[Orion1]

Çok teşekkürler evren bey..

Rica ederim.İyi çalışmalar.

 

[Ridan]

Evren bey, yeni farkettim. Aşağıdaki kod ile aktarma yapıyorum. Tek satırlık kayıt olursa K sütunundaki tarihi en son hücreye (K1048576) kadar dolduruyor. Bu durumu düzeltebilir miyiz? Birden fazla kayıt olursa tarih atmada sorun olmuyor.

Sub aktar2()
Dim s As Integer
Dim sat As Integer
Dim alan As Range
Dim sh As Worksheet, sat2 As Long
sat = Sheets("ARŞİV").Cells(Rows.Count, "B").End(xlUp).Offset(1, 0).Row
son = Sheets("FATURA").Cells(Rows.Count, "B").End(3).Row
Set sh = Sheets("ARŞİV")
sat2 = sh.Cells(Rows.Count, "B").End(xlUp).Row + 1
If son > 502 Then son = 502
For s = 3 To son Step 1
If Sheets("FATURA").Cells(s, "B") <> "" Then
    If alan Is Nothing Then
        Set alan = Sheets("FATURA").Range("B" & s & ":H" & s & ",M" & s & ",N" & s)
        sh.Cells(sat2, "K").Value = Date
        sat2 = sat2 + 1
    Else
        Set alan = Union(alan, Sheets("FATURA").Range("B" & s & ":H" & s & ",M" & s & ",N" & s))
        sh.Cells(sat2, "K").Value = Date
        sat2 = sat2 + 1
    End If
End If
Next s

On Error Resume Next    ' Eğer sayfada hiç kayıt yoksa alttaki satır hata veriyor
alan.Copy
Sheets("ARŞİV").Range("B" & sat).PasteSpecial xlPasteValues
End Sub