Son Dolu Satıra kadar makro ile yazdırmak

[walabi]

Merhaba,

Ekli dosyada bir adet örnek veri var. İstemiş olduğum şey, veri adlı sayfanın R,S,T sütunlarındaki verilerin makro ile yazdırılması. R sütununa kadar olan veriler logo sisteminden alınan ham verileridir. Satır sayısı , alınan rapora göre, 100 de olabilir 100.000 de. Amacım R,S,T sütunlarına yazmış olduğum formülleri makro ile son satıra kadar yazdırmak. Destek olunabilir mi? A sütununa göre makro oluşturulabilir.

 

[tascimehmet]

ekte kayıtlıdır umarım istediginiz şekilde olmuştur.
sizin yaptıgınız formüllere göre uyarladım.

 

[tascimehmet]

Sub hareket()
Dim i As Integer
For i = 2 To Range("a200000").End(3).Row
    If Cells(i, 1) = "(14) Devir Fişi" Then
        Cells(i, 18) = "ARTI"
    ElseIf Cells(i, 1) = "(07) Perakende Satış İrsaliyesi" Or (Cells(i, 1) = "(06) Satınalma İade İrsaliyesi") _
        Or (Cells(i, 1) = "(08) Toptan Satış İrsaliyesi") Then
        Cells(i, 18) = "EKSİ"
    ElseIf Cells(i, 1) = "(01) Satınalma İrsaliyesi" Or (Cells(i, 1) = "(02) Perakende  Satış İade İrsaliyesi") _
        Or (Cells(i, 1) = "(03) Toptan Satış İade İrsaliyesi") Then
        Cells(i, 18) = "ARTI"
    ElseIf (Cells(i, 1) = "(25) Ambar Fişi") And Cells(i, 8) = "Giriş" Then
        Cells(i, 18) = "ARTI"
    ElseIf (Cells(i, 1) = "(25) Ambar Fişi") And Cells(i, 8) = "Çıkış" Then
        Cells(i, 18) = "EKSİ"
    ElseIf Cells(i, 1) = "(51) Sayım Eksiği Fişi" Or (Cells(i, 1) = "(11) Fire Fişi") Then
        Cells(i, 18) = "TANIMSIZ"
    End If
        If (Cells(i, 18) = "ARTI") And Cells(1, 14) = "Miktar" Then
            Cells(i, 19) = Cells(i, 14) * (1)
        ElseIf (Cells(i, 18) = "EKSİ") And Cells(1, 14) = "Miktar" Then
            Cells(i, 19) = Cells(i, 14) * (-1)
    End If
            Cells(i, 20) = Left(Cells(i, 11), 2)

Next i
End Sub

 

[çıtır]

Alternatif olsun.

Sub formulyaz()
Dim s1 As Worksheet
Set s1 = Sheets("VERİ")
Application.ScreenUpdating = False
son = s1.Cells(100000, "A").End(3).Row
s1.Range("R2:T" & Rows.Count).Cells.ClearContents
s1.Range("R2").FormulaLocal = "=EĞER(YADA(VE(A2" & "=" & """Ambar Fişi""" & ";" & "H2" & "=" & """Giriş""" & ")" & ";" & " YADA(A2" & "=" & """(14) Devir Fişi""" & ";" & "A2" & "=" & """(01) Satın alma irsaliyesi""" & ";" & "A2" & "=" & """(02) Parakende Satış  iade irsaliyesi""" & ";" & "A2" & "=" & """(03) Toptan iade satış irsaliyesi""" & "))" & ";" & """ARTI""" _
& ";" & " EĞER(YADA(VE(A2" & "=" & """Ambar Fişi""" & ";" & "H2" & "=" & """Çıkış""" & ")" & ";" & " YADA(A2" & "=" & """(07) Parakende satış irsaliyesi""" & ";" & "A2" & "=" & """(06) Satın alma iade irsaliyesi""" & ";" & "A2" & "=" & """(08) Toptan Satış irsaliyesi""" & "))" & ";" & """EKSİ""" & ";" & "EĞER(YADA(A2" & "=" & """(51) Sayım Eksiği Fişi""" & ";" & "A2" & "=" & """(11) Fire fişi""" & ")" & ";" & """TANIMSIZ""" & "; """")))"
s1.Range("S2").FormulaLocal = "=EĞER(R2" & " = " & """EKSİ""" & ";" & -1 & ";" & "Eğer(R2" & "=" & """ARTI""" & ";" & 1 & "; """" ))"
s1.Range("T2").FormulaLocal = "=Soldan(K2" & ";" & 2 & ")"
s1.Range("R2:T2").Select
Selection.Copy
s1.Range("R3:T" & son).Select
Selection.PasteSpecial Paste:=xlPasteFormulas, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
         Application.CutCopyMode = False
 s1.Range("A2").Select
Application.ScreenUpdating = True
MsgBox "İŞLEM TAMAM", vbInformation, "FORMÜL YAZMA"
End Sub

 

[walabi]

Cevaplarınız için teşekkürler,

 

[çıtır]

Cevaplarınız için teşekkürler,

Rica ederim.Dönüş yaptığınız için teşekkür ederim.