Ay ve Yıl seçeneğine göre çalışan makro

[1Al2Ver]

Merhaba,

Sub aktar()
Sheets("2009").Range("C3:C31").Value = Sheets("Aylık").Range("AH4:AH30").Value
Sheets("2009").Range("D3: D31").Value = Sheets("Aylık").Range("AI4:AI30").Value
MsgBox "Aktarıldı"
End Sub

kodu ile "Aylık" sayfasındaki AH4:AH30 ve AI4:AI30 aralığını, "2009" sayfasındaki C3:C31 ve D3: D31 aralığına aktarabilmekteyim,

İsteğim; "Aylık" sayfasında AH1'deki ay ismine ve AI1'deki yıla göre seçim yapıp aktarmak,

Kısaca özetlemem ve örneklemem gerekirse;

Eğer Aylık Sayfası AH1=Mart, AI1=2005 ise ;"Aylık" sayfasındaki AH4:AH30 ve AI4:AI30 aralığını, "2005" sayfasındaki M3:M31 ve N3:N31 aralığına aktar,

Eğer Aylık Sayfası AH1=Mart, AI1=2007 ise ;Aylık" sayfasındaki AH4:AH30 ve AI4:AI30 aralığını, "2007" sayfasındaki G3:G31 ve H3:H31 aralığına aktar,

Eğer Aylık Sayfası AH1=Ocak, AI1=2009 ise ;"Aylık" sayfasındaki AH4:AH30 ve AI4:AI30 aralığını, "2009" sayfasındaki C3:C31 ve D3: D31 aralığına aktar,

Eğer Aylık Sayfası AH1=Şubat, AI1=2009 ise ;Aylık" sayfasındaki AH4:AH30 ve AI4:AI30 aralığını, "2009" sayfasındaki E3:E31 ve F3:F31 aralığına aktar,

...şeklinde giden 12 aylık bir aktarma makrosuna ihtiyacım var,

Teşekkür ederim.

 

[1Al2Ver]

Merhaba,

Yıl seçmeden sadece AH1'i (ay) seçersek, yani

Eğer AH1="Ocak" ise
Eğer AH1="Şubat" ise......

Sub aktar()

If ("AH1") = "Ocak" Then
Sheets("2009").Range("C3:C31").Value = Sheets("Aylık").Range("AH4:AH30").Value
Sheets("2009").Range("D3: D31").Value = Sheets("Aylık").Range("AI4:AI30").Value
End If

If ("AH1") = "Şubat" Then
Sheets("2009").Range("E3:E31").Value = Sheets("Aylık").Range("AH4:AH30").Value
Sheets("2009").Range("F3: F31").Value = Sheets("Aylık").Range("AI4:AI30").Value
MsgBox "Aktarıldı"
End If
End Sub

şeklinde her ay için alt alta 12 takım makro yazabilsek, sorun bu şekliyle de çözülmüş olur

Sub aktar()

If ("AH1") = "Ocak" Then
Sheets("2009").Range("C3:C31").Value = Sheets("Aylık").Range("AH4:AH30").Value
Sheets("2009").Range("D3: D31").Value = Sheets("Aylık").Range("AI4:AI30").Value
End If
End Sub

şekliyle yazdığımda işlem yapmamakta, sanırım eksik bir komut var, yardımcı olursanız memnun olacağım,

Teşekkür ederim.

 

[1Al2Ver]

Merhaba,

2 nolu mesajdaki isteğim doğrultusunda bir öneriniz yada çözümünüz varsa memnun olacağım,

Eğer Ah1 = "Ocak" ise
Eğer Ah1 ="Şubat" ise....

Sub aktar()

If ("AH1") = "Ocak" Then
Sheets("2009").Range("C3:C31").Value = Sheets("Aylık").Range("AH4:AH30").Value
Sheets("2009").Range("D3: D31").Value = Sheets("Aylık").Range("AI4:AI30").Value
End If

If ("AH1") ="Şubat" Then
Sheets("2009").Range("E3:E31").Value = Sheets("Aylık").Range("AH4:AH30").Value
Sheets("2009").Range("F3: F31").Value = Sheets("Aylık").Range("AI4:AI30").Value
End If
End Sub

Bu formül işlem yapmamakta, teşekkür ederim.

 

[Ayhan Ercan]

Merhaba

Ek dosyayı inceleyiniz.

Sub aktar()
Dim hcr As String, ay As Range
hcr = Sheets("Aylık").Range("AI1").Text
Set ay = Sheets(hcr).Range("c1:y1").Find(Sheets("Aylık").Range("AH1").Text, lookat:=xlWhole)
Sheets(hcr).Range(Sheets(hcr).Cells(3, ay.Column), Sheets(hcr).Cells(31, ay.Column)).Value = Sheets("Aylık").Range("AH4:AH30").Value
Sheets(hcr).Range(Sheets(hcr).Cells(3, ay.Column + 1), Sheets(hcr).Cells(31, ay.Column + 1)).Value = Sheets("Aylık").Range("AI4:AI30").Value
MsgBox "Aktarıldı"
End Sub

 

[1Al2Ver]

Merhaba

Ek dosyayı inceleyiniz.

Sub aktar()
Dim hcr As String, ay As Range
hcr = Sheets("Aylık").Range("AI1").Text
Set ay = Sheets(hcr).Range("c1:y1").Find(Sheets("Aylık").Range("AH1").Text, lookat:=xlWhole)
Sheets(hcr).Range(Sheets(hcr).Cells(3, ay.Column), Sheets(hcr).Cells(31, ay.Column)).Value = Sheets("Aylık").Range("AH4:AH30").Value
Sheets(hcr).Range(Sheets(hcr).Cells(3, ay.Column + 1), Sheets(hcr).Cells(31, ay.Column + 1)).Value = Sheets("Aylık").Range("AI4:AI30").Value
MsgBox "Aktarıldı"
End Sub

Sayın Ayhan Ercan merhaba,

Çözüm için çok çok teşekkür ederim, ne yapsam emeğinizi ödeyemem, elinize sağlık, hem sorunum çözüldü hem de benzer sorulara örnek oldu,

Tekrar teşekkür ederim, saygılarımla.

 

[Ayhan Ercan]

Sayın Ayhan Ercan merhaba,

Çözüm için çok çok teşekkür ederim, ne yapsam emeğinizi ödeyemem, elinize sağlık, hem sorunum çözüldü hem de benzer sorulara örnek oldu,

Tekrar teşekkür ederim, saygılarımla.

Rica ederim.
İyi Çalışmalar...