Merhaba Arkadaşlar

Eklediğim uygulamada L1 Hücresine yazdığım rakama göre aktarma yapsın.

Örneğin L1 1 yazdığım zaman
Ocak Ayına aktarma yapsın
A2 deki veriyi Ocak ayına Q4 e aktarsın
B2 deki veriyi Ocak ayına R4 e aktarsın
D2 deki veriyi Ocak ayına S4 e aktarsın
F2 deki veriyi Ocak ayına U4 e aktarsın
G2 deki veriyi Ocak ayına V4 e aktarsın
H2 deki veriyi Ocak ayına W4 e aktarsın

L1 E 2 yazdığımız zaman şubat ayına aktarsın

Sayın m_demir

Aktar butonuna aşağıdaki kodu yazarak dener misiniz?

With ThisWorkbook.Sheets("Sayfa1")

 Dim i As Long

  i = .Range("L1") + 3

        .Range("Q" & i & ":" & "R" & i).Value = .Range("A2:C2").Value

        .Range("U" & i & ":" & "V" & i).Value = .Range("F2:G2").Value

        .Range("S" & i).Value = .Range("Q" & i).Value - Range("R" & i).Value

        .Range("W" & i).Value = .Range("U" & i).Value - Range("V" & i).Value

    End With

    MsgBox "İşlem Tamamlandı"

Çok teşekkürler Hocam ellerinize sağlık tam istediğim gibi olmuş.

*Hocam L1 hücresi boş olduğu zaman uyarı verse çok iyi olur.

*Aktarılacak Hücreler dolu ise Daha önce aktarma yarılmış, verileri değiştirmek istiyormusunuz evet hayıt onayı istesin.

Sub Aktar()

If Range("L1") = "" Or Range("L1") > 12 Then

 MsgBox "L1 Alanına geçerli bir değer girmediniz."

    Else

 With ThisWorkbook.Sheets("Sayfa1")

 Dim i As Long

 

  i = .Range("L1") + 3

    If Range("Q" & i).Value = "" Then

        .Range("Q" & i & ":" & "R" & i).Value = .Range("A2:C2").Value

        .Range("U" & i & ":" & "V" & i).Value = .Range("F2:G2").Value

        .Range("S" & i).Value = .Range("Q" & i).Value - Range("R" & i).Value

        .Range("W" & i).Value = .Range("U" & i).Value - Range("V" & i).Value

    Else

    

    If MsgBox("Kaydetmek istediğiniz alanda kayıt var. Değişiklik yapılsın mı?", vbCritical + vbYesNo + vbDefaultButton1, "UYARI") = vbNo Then Exit Sub

      .Range("Q" & i & ":" & "R" & i).Value = .Range("A2:C2").Value

        .Range("U" & i & ":" & "V" & i).Value = .Range("F2:G2").Value

        .Range("S" & i).Value = .Range("Q" & i).Value - Range("R" & i).Value

        .Range("W" & i).Value = .Range("U" & i).Value - Range("V" & i).Value

      End If

      

End With

        MsgBox "İşlem Tamamlandı"

    End If

End Sub

Üstteki kodu dener misin?

Çok, çok teşekkürler Hocam ellerinize sağlık. Tam istediğim gibi olmuş.

Hocam konuyu taşıtabilirsiniz saygılarımla sağlıklı günler diliyorum.