• DİKKAT

    DOSYA İndirmek/Yüklemek için ÜCRETLİ ALTIN ÜYELİK Gereklidir!
    Altın Üyelik Hakkında Bilgi

Hücreye Girilen rakama gire tarih oluşturma makrosu

sirkülasyon

sirkülasyon

Altın Üye
Katılım
10 Temmuz 2012
Mesajlar
2,543
Excel Vers. ve Dili
2021 LTSC TR
Selamün Aleyküm

E4 hücresinde Ay adı yazılı "Ocak, Şubat, Mart" Gibi
F4 hücresine 18 yazığım zaman "18.09.2017" yazacak. 21 yazıdğım zaman "21.09.2017" yazacak. YIL içinde bulunduğumuz yılı alacak.

G4 hücresine ise ise ay sonunu alacak. Örneğin Eylül ayı 2017 yılı içerisinde 30 çekmektedir. Kullanıcı G4 hücresine 30 yazdığı zaman "30.09.2017" tarihini alacak.

Sehven
a) 31 yazdığım zaman hücreye "31.09.2017" yazmayacak. Uyarı verecek. Uyarı "Eylül 2017 30 çekmektedir. Tekrar deneyiniz" şeklinde olacak.
b) 27 yazdığım zaman hücreye "27.09.2017" yazmayacak. Uyarı verecek. Uyarı "Eylül 2017 30 çekmektedir. Tekrar deneyiniz" şeklinde olacak.

böyle bir makroya ihtiyacım var yardımcı olmanızı bekliyor saygılarımı sunarım
 
Aşağıdaki kodları deneyin.
Kod: 
Private Sub Worksheet_Change(ByVal Target As Range)
'Kod : ASKM
If Intersect(Target, [F4]) Is Nothing Then Exit Sub
On Error Resume Next
Select Case Range("E4").Value
    Case "OCAK", "Ocak", "ocak"
        Target.Value = DateSerial(Year(Date), 1, Target.Value)
        [G4] = DateSerial(Year(Date), 1, 31)
        Exit Sub
    Case "ŞUBAT", "Şubat", "şubat"
        Target.Value = DateSerial(Year(Date), 2, Target.Value)
        If (Year(Date) Mod 4) = 0 Then
            [G4] = DateSerial(Year(Date), 2, 29)
        Else
            [G4] = DateSerial(Year(Date), 2, 28)
        End If
        Exit Sub
    Case "MART", "Mart", "mart"
        Target.Value = DateSerial(Year(Date), 3, Target.Value)
        [G4] = DateSerial(Year(Date), 3, 31)
        Exit Sub
    Case "NİSAN", "Nisan", "nisan"
        Target.Value = DateSerial(Year(Date), 4, Target.Value)
        [G4] = DateSerial(Year(Date), 4, 30)
        Exit Sub
    Case "MAYIS", "Mayıs", "mayıs"
        Target.Value = DateSerial(Year(Date), 5, Target.Value)
        [G4] = DateSerial(Year(Date), 5, 31)
        Exit Sub
    Case "HAZİRAN", "Haziran", "haziran"
        Target.Value = DateSerial(Year(Date), 6, Target.Value)
        [G4] = DateSerial(Year(Date), 6, 30)
        Exit Sub
    Case "TEMMUZ", "Temmuz", "temmuz"
        Target.Value = DateSerial(Year(Date), 7, Target.Value)
        [G4] = DateSerial(Year(Date), 7, 31)
        Exit Sub
    Case "AĞUSTOS", "Ağustos", "ağustos"
        Target.Value = DateSerial(Year(Date), 8, Target.Value)
        [G4] = DateSerial(Year(Date), 8, 31)
        Exit Sub
    Case "EYLÜL", "Eylül", "eylül"
        Target.Value = DateSerial(Year(Date), 9, Target.Value)
        [G4] = DateSerial(Year(Date), 9, 30)
        Exit Sub
    Case "EKİM", "Ekim", "ekim"
        Target.Value = DateSerial(Year(Date), 10, Target.Value)
        [G4] = DateSerial(Year(Date), 10, 31)
        Exit Sub
    Case "KASIM", "Kasım", "kasım"
        Target.Value = DateSerial(Year(Date), 11, Target.Value)
        [G4] = DateSerial(Year(Date), 11, 30)
        Exit Sub
    Case "ARALIK", "Aralık", "aralık"
        Target.Value = DateSerial(Year(Date), 12, Target.Value)
        [G4] = DateSerial(Year(Date), 12, 31)
        Exit Sub
End Select
End Sub
 
Merhaba.

Sorunuzun tam karşılığına ulaştınız mı bilmiyorum.

Aşağıdaki kodu da dener misiniz? En azından alternatif olsun.

Kod'u, alt taraftan, işlem yapılacak sayfanın adına fareyle sağ tıklayıp KOD GÖRÜNTÜLEyi
seçtiğinizde açılan VBA ekranında sağdaki boş alana yapıştırın.
.
Kod: 
[B]Private Sub Worksheet_Change(ByVal Target As Range)[/B]
If Intersect(Target, [E4, F4]) Is Nothing Then Exit Sub

If [E4] = "" Or [F4] = "" Then
    [G4] = "": Exit Sub
ElseIf Target.Address(0, 0) = "E4" Then
    Aylar = Array("OCAK", "ŞUBAT", "MART", "NİSAN", "MAYIS", "HAZİRAN", _
        "TEMMUZ", "AĞUSTOS", "EYLÜL", "EKİM", "KASIM", "ARALIK")
    aye = WorksheetFunction.Match([E4], Aylar, 0)
    sone = DateSerial(Year(Now()), aye + 1, 0)
        If Day([F4]) > Day(sone) Then
            MsgBox "Tarih düzeltilecek."
            [F4] = sone: Exit Sub
        Else
            [F4] = DateSerial(Year(Now()), aye, Day([F4]))
        End If
            MsgBox "Tarih düzeltildi."
End If

Aylar = Array("OCAK", "ŞUBAT", "MART", "NİSAN", "MAYIS", "HAZİRAN", _
        "TEMMUZ", "AĞUSTOS", "EYLÜL", "EKİM", "KASIM", "ARALIK")
ay = WorksheetFunction.Match([E4], Aylar, 0)

If Year([F4]) = 1900 Then
    son = DateSerial(Year(Now()), ay + 1, 0)
    yazilan = [F4] - DateSerial(1900, 1, 1) + 2
    ay2 = Month(DateSerial(Year(Now()), ay, yazilan))
        If ay2 > ay Then
            [F4] = DateSerial(Year(Now()), ay + 1, 0)
        Else
            [F4] = DateSerial(Year(Now()), ay, yazilan)
        End If
End If
[G4] = DateSerial(Year(Now()), ay + 1, 0)
[B]End Sub[/B]
 
askm ve Ömer BARAN' a sonsuz teşekkür ederim.
Ellerinize sağlık. Hakkınızı helal edin
 
ASKM makrosunda sıkıntı yok ama
Ömer BARAN uzmanım
F4 hücresine 1 girildiği zaman Tarih hatalı çıkıyor. Kontrol edebilmeniz mümkün mü?
 
Ömer üstadım sanırım müsait değil. Kodlarına ufak bir müdahele yaptım.
Kod: 
Private Sub Worksheet_Change(ByVal Target As Range)
If Intersect(Target, [E4, F4]) Is Nothing Then Exit Sub

If [E4] = "" Or [f4] = "" Then
    [G4] = "": Exit Sub
ElseIf Target.Address(0, 0) = "E4" Then
    Aylar = Array("OCAK", "ŞUBAT", "MART", "NİSAN", "MAYIS", "HAZİRAN", _
        "TEMMUZ", "AĞUSTOS", "EYLÜL", "EKİM", "KASIM", "ARALIK")
    aye = WorksheetFunction.Match([E4], Aylar, 0)
    sone = DateSerial(Year(Now()), aye + 1, 0)
        If Day([f4]) > Day(sone) Then
            MsgBox "Tarih düzeltilecek."
            [f4] = sone: Exit Sub
        Else
            [f4] = DateSerial(Year(Now()), aye, Day([f4]))
        End If
            MsgBox "Tarih düzeltildi."
End If

Aylar = Array("OCAK", "ŞUBAT", "MART", "NİSAN", "MAYIS", "HAZİRAN", _
        "TEMMUZ", "AĞUSTOS", "EYLÜL", "EKİM", "KASIM", "ARALIK")
ay = WorksheetFunction.Match([E4], Aylar, 0)
If [f4] > 1 Then
If Year([f4]) = 1900 Then
    son = DateSerial(Year(Now()), ay + 1, 0)
    yazilan = [f4] - DateSerial(1900, 1, 1) + 2
    ay2 = Month(DateSerial(Year(Now()), ay, yazilan))
        If ay2 > ay Then
            [f4] = DateSerial(Year(Now()), ay + 1, 0)
        Else
            [f4] = DateSerial(Year(Now()), ay, yazilan)
        End If
End If
[G4] = DateSerial(Year(Now()), ay + 1, 0)
Else
[f4] = DateSerial(Year(Now()), ay, 1)
[G4] = DateSerial(Year(Now()), ay + 1, 0)
End If
End Sub
 
Teşekkür eder saygılarımı sunarım.
Sağolasın askm
 
Merhaba,

Alternatif:

Kod: 
Private Sub Worksheet_Change(ByVal Target As Range)

    Dim trh As Date
    
    If Intersect(Target, [F4]) Is Nothing Then Exit Sub

    With Target
        If .Value = "" Then Exit Sub
        .NumberFormat = "@"
        Application.EnableEvents = False
        
        On Error GoTo atla
        trh = .Value & "." & .Offset(0, -1)
        If Year(trh) <> Year(Date) Then
            MsgBox "Seçilen Ayda " & .Value & " Tarihli Gün Yok."
            .Value = "": .Offset(0, 1) = ""
            Application.EnableEvents = True
            Exit Sub
        End If
        
        .Value = CLng(trh)
        .NumberFormat = "dd/mm/yyyy"
        Application.EnableEvents = True
        .Offset(0, 1) = DateSerial(Year(Date), Month(.Value) + 1, 0)
        Exit Sub
    
atla:
        MsgBox .Offset(0, -1) & "- Bu İsimde Ay Yok"
        .Value = "": .Offset(0, 1) = ""
        Application.EnableEvents = True
        Exit Sub
    End With
    
End Sub

.
 
Cevap yazmak için giriş yap yada kayıt ol.
Geri
Üst