Soru Aynı konuma aktarma-kod düzeltme

[mkarakas_58]

Merhaba Arkadaşlar,

Aşağıdaki kodda bir isteğim olacak. H1'deki değere göre a5: d35 arasını kurala göre ilgili yere aktarıyor. Sorunum yok. Ama a5:d35 değişken olmaktadır. Buna göre;

H1=1 olsun. Bu kurala göre A5: D35 arasını, M5: p35 arasına göre aktardı. Sorun yok. Benim A5: D35 arası değişti. Ve bu değişikliği gene H1=1 kuralına göre M:5: D35 arasına aktarmasını istiyorum. Ama kodlar daha önce M5: p35 arasına aktardığı için son değişikliği M36: p66 arasına aktarıyor. M-P süntünların altına listeyi ekleyerek gidiyor. Bunu istemiyorum.

H1=1 e göre a5: d35 'i devamlı m5: p35 'e aktarsın.
H1=2 ye göre a5: d35 'i devamlı t5: w35 'e aktarsın
...

Private Sub Worksheet_Change(ByVal Target As Range)

    If Intersect(Target, [H1]) Is Nothing Then Exit Sub

    On Error Resume Next

    If Int(Target) <> Target Then MsgBox "1-12 arasında tamsayı giriniz.", vbCritical, " ": Exit Sub

    If Target < 1 Or Target > 12 Then MsgBox "1-12 arasında tamsayı giriniz.", vbCritical, " ": Exit Sub

    Application.EnableEvents = False

    sut = ((Target - 1) * 7) + 13

    ss = Cells(Rows.Count, sut).End(xlUp).Row + 1

    If ss < 5 Then ss = 5

    Cells(ss, sut).Resize(31, 4).Value = Range("A5:D35").Value

    Cells(5, sut).Resize(ss + 26, 1).Formula = "=IF(C4="""","""",ROW()-4)"

    Cells(5, sut).Resize(ss + 30, 1).Value = Cells(5, sut).Resize(ss + 30, 1).Value

    Application.EnableEvents = True

    MsgBox "Veriler " & Target & ". döneme aktarıldı.", vbInformation, " "

End Sub

 

[Korhan Ayhan]

Deneyiniz.

Private Sub Worksheet_Change(ByVal Target As Range)
    If Intersect(Target, [H1]) Is Nothing Then Exit Sub
    On Error Resume Next
    If Int(Target) <> Target Then MsgBox "1-12 arasında tamsayı giriniz.", vbCritical, " ": Exit Sub
    If Target < 1 Or Target > 12 Then MsgBox "1-12 arasında tamsayı giriniz.", vbCritical, " ": Exit Sub
    Application.EnableEvents = False
    sut = ((Target - 1) * 7) + 13
    Cells(5, sut).Resize(31, 4).Value = Range("A5:D35").Value
    Application.EnableEvents = True
    MsgBox "Veriler " & Target & ". döneme aktarıldı.", vbInformation, " "
End Sub