ChatGPT'den tarih çözümü

[netzone]

Korhan Bey,

Akış şeması olarak böyle görünüyor arkadaşımızın isteği, belki daha net anlaşılır.
Düzeltme: ** Koşul1 > Evet den sonra çizgiyi yanlış çizmiş tatil kontorülüne gitmesi gerekiyordu düzeltilmiş görseli ekledim.

Option Explicit

' ANA FONKSİYON: Hücrede =PersembeSorgula(A1) olarak kullanılır
Function PersembeSorgula(hucre As Range) As Variant
Dim hedefTarih As Date
Dim adayTarih As Date
Dim tatilAraligi As Range
Dim sayac As Integer

' Giriş Kontrolü
If Not IsDate(hucre.Value) Then
PersembeSorgula = "Hatalı Tarih"
Exit Function
End If

' Şema Adım 1: A1 + 90 Gün
hedefTarih = hucre.Value + 90

' Şema Adım 2: Durakları Belirle ve Başlangıç Adayını Seç
adayTarih = IlkDuragiSec(hedefTarih)

' Şema Adım 3: Tatil Kontrolü ve Zıplama Döngüsü
' Sayfada "resmi_tatiller" adında bir alan tanımlanmış olmalıdır.
On Error Resume Next
Set tatilAraligi = Range("resmi_tatiller")
On Error GoTo 0

sayac = 0
' Şemadaki "Evet" oku: Tatil listesinde olduğu sürece zıpla
Do While TatilListesindeVarMi(adayTarih, tatilAraligi) And sayac < 15
adayTarih = BirSonrakiDuragaZıpla(adayTarih)
sayac = sayac + 1
Loop

' Şema Adım 4: Bitiş ve Sonuç
PersembeSorgula = adayTarih
End Function

' Şemadaki Koşul 1 ve Koşul 2 Karar Mekanizması
Private Function IlkDuragiSec(t As Date) As Date
Dim P2 As Date, P4 As Date
P2 = NPersembeBul(Year(t), Month(t), 2)
P4 = NPersembeBul(Year(t), Month(t), 4)

If t <= P2 Then
IlkDuragiSec = P2
ElseIf t <= P4 Then
IlkDuragiSec = P4
Else
' Sonraki Ay P2
IlkDuragiSec = NPersembeBul(Year(DateAdd("m", 1, t)), Month(DateAdd("m", 1, t)), 2)
End If
End Function

' Şemadaki "Değiştir: Bir Sonraki Durağa Atla" İşlemi
Private Function BirSonrakiDuragaZıpla(mevcut As Date) As Date
' Eğer mevcut gün ayın 15'inden küçükse (2. Perşembedir), 4. Perşembeye geç
If Day(mevcut) < 15 Then
BirSonrakiDuragaZıpla = NPersembeBul(Year(mevcut), Month(mevcut), 4)
Else
' 4. Perşembedeysek sonraki ayın 2. Perşembesine geç
Dim sonraki As Date
sonraki = DateAdd("m", 1, DateSerial(Year(mevcut), Month(mevcut), 1))
BirSonrakiDuragaZıpla = NPersembeBul(Year(sonraki), Month(sonraki), 2)
End If
End Function

' Yardımcı: N. Perşembe Gününü Hesaplar
Private Function NPersembeBul(Yil As Integer, Ay As Integer, N As Integer) As Date
Dim ilk As Date
Dim fark As Integer
ilk = DateSerial(Yil, Ay, 1)
fark = (4 - Weekday(ilk, vbMonday) + 7) Mod 7
NPersembeBul = ilk + fark + ((N - 1) * 7)
End Function

' Yardımcı: Tatil Kontrolü
Private Function TatilListesindeVarMi(t As Date, r As Range) As Boolean
If r Is Nothing Then
TatilListesindeVarMi = False
Else
TatilListesindeVarMi = WorksheetFunction.CountIf(r, t) > 0
End If
End Function

 

[netzone]

Ayrıca dediğiniz gibi 11.06.2026 tarihi de resmi tatil olsaydı. Bu sefer sonuç ne olacaktı?

18.06.2026 ya da 25.06.2026

Korhan Bey, varılmak istenen tarih ilgili ayın 2. ve 4. Perşembe günü. Aşıyorsa 4.perşembeyi takip eden ayın 2.perşembesi resmi tatile denk geldikçe 2.perşembe 4.perşeme olarak ilerleyecek şekilde resmi tatil olmayana kadar kontrol etmesi sonucu her koşula uygun bir tarihe ulaşılması istenmiş.

 

[Korhan Ayhan]

Yardımcı sütunlarla hazırladığım çözümü ekliyorum. Zaten temel kurgu sizin paylaştığınız formül gibi.

Ben sadece sütunlara parçalayarak okunur olmasını sağlamaya çalıştım. Umarım mantık hatası olmamıştır.