Belirtilen iki tarih aralığını satırlara yazma

[meleklerim]

Elimde bazı olayların başlangıç ve bitiş tarihlerinin olduğu bir tablo var. Ben yandaki sütuna bu aralıkları gün gün sıralamak istiyorum. Örneğin B sütununda başlangıç 15.01.2019, C sütununda bitiş 18.01.2019 yazıyorsa D sütununa 15.01.2019, 16.01.2019, 17.01.2019, 18.01.2019 değerlerini alt alta satırlara otomatik olarak yazılmasını istiyorum. Örnek dosyayı ekliyorum. Yardımcı olacaklara şimdiden teşekkür ederim

 

[Muzaffer Ali]

Merhaba.
Aşağıdaki kodu sayfanın kod kısmına kopyalayıp çalıştırın.

Sub Test()
    Dim Bak As Integer
    Dim Satir As Integer
    Dim Fark As Long
    Range("D2:D" & Rows.Count).ClearContents
    For Bak = 2 To Cells(Rows.Count, "B").End(xlUp).Row
        Satir = Cells(Rows.Count, "D").End(xlUp).Row + 1
        Cells(Satir, "D") = FormatDateTime(Cells(Bak, "B"), vbShortDate)
        If Not Cells(Bak, "C") = "" Then
            Fark = Cells(Bak, "C") - Cells(Bak, "B")
            Range("D" & Satir + 1 & ":D" & Satir + Fark).Formula = "=1 + D" & Satir
        End If
    Next
    Range("D2:D" & Satir + Fark).NumberFormat = "dd/mm/yyyy"
    Range("D2:D" & Satir + Fark).Copy
    Range("D2").PasteSpecial xlPasteValues
    Application.CutCopyMode = False
End Sub

 

[meleklerim]

yardımcı olduğunuz için çok teşekkür ederim, işimi görüyor

 

[meleklerim]

Yalnız kullanımda bir hatası çıktı. Şöyle ki, başlangıç ve bitiş tarihlerini tek tek girip her tarihten sonra makroyu çalıştırınca hatasız veriyor. Ama tabloda tüm tarihler önceden girilmiş ise sadece tablonun son satırına kadar veriyor. Yani D ye veri girmeyi B nin satır sayısınca yapıyor.
kodun çalışma mantığınn böyle olması gerekiyor ancak kırmızı ile yazdığım adımda sadece B nin satır sayısı kadar gidiyor.
#B2 ile c2 ye bak
#iki tarih arasını D2 den başlayarak satırlara yaz
#B3 ile C3 e bak
#iki tarih arasını D nin son boş satırından başlayarak sırala
#B sutununda son dolu satıra kadar git

@Muzaffer Ali

 

[Muzaffer Ali]

Ben pek bir şey anlamadım.
D sütununu en son sıralama mı yapsın?

 

[meleklerim]

tek tek girince sorunsuz zaten. ama bazen girilen baş ve bit tarihleri güncelleniyor, siliniyor vs. o zaman makro çalışınca sadece B sütünun satır sayısınca gidiyor. daha ileri gitmiyor. Her seferinde tabloya veri eklendiğinde, silindiğinde, değitirildiğinde toplu halde de tabloyu baştan sıralayabilmeli

 

[meleklerim]

sizi de yoruyorum hakkınızı helal edin

 

[Muzaffer Ali]

tek tek girince sorunsuz zaten. ama bazen girilen baş ve bit tarihleri güncelleniyor, siliniyor vs. o zaman makro çalışınca sadece B sütünun satır sayısınca gidiyor. daha ileri gitmiyor. Her seferinde tabloya veri eklendiğinde, silindiğinde, değitirildiğinde toplu halde de tabloyu baştan sıralayabilmeli

Başlama tarihleri B sütununda yazdığına göre elbette B sütununun sayısınca olacak, eğer B'de tarih yoksa zaten durması gerekir.

Kodları revize ettim aşağıdaki kodlar daha verimli çalışır.

Sub Test()
    Dim Bak As Integer
    Dim Satir As Integer
    Dim Fark As Long
    Dim BakFark As Long
    Range("D2:D" & Rows.Count).ClearContents
    For Bak = 2 To Cells(Rows.Count, "B").End(xlUp).Row
        Satir = Cells(Rows.Count, "D").End(xlUp).Row + 1
        Cells(Satir, "D") = FormatDateTime(CDate(Cells(Bak, "B")), vbShortDate)
        If Not Cells(Bak, "C") = "" Then
            Fark = Cells(Bak, "C") - Cells(Bak, "B")
            For BakFark = Satir + 1 To Satir + Fark
                Cells(BakFark, "D") = FormatDateTime(1 + CDate(Cells(BakFark - 1, "D")), vbShortDate)
            Next
        End If
    Next
   
    MsgBox "Tamamlandı."
End Sub

 

[meleklerim]

teşekkürler, sıralamanız güne göre sıralıyor. Aya yıla bakmıyor. O bakımdan benim için kullanışsız. .Sıralama B sütunu için olsaydı daha kullanışlı olurdu. Sıralamayı çıkardığımda da userform üzerinde şu stırında hata veriyor
Cells(BakFark, "D") = FormatDateTime(1 + CDate(Cells(BakFark - 1, "D")), vbShortDate)

örnek dosyada çalışırken o hatayı almıyorum halbuki. Sıralamasız halini atabilir misiniz? dedğiniz yerden silince end if next with hangisi kalacak çıkacak çözemiyorum

 

[Muzaffer Ali]

Kodu yeniledim.

 

[meleklerim]

malesef bazen sonsuz bir döngüye giriyor, sayfanın son satırına kadar yazıyor (c deki bitiş tarihini dikkate almıyor) bazen hiç çalışmıyor. Sizide yordum kusurua bakmayın eski sistem elle girmeye devam anlaşılan

 

[Muzaffer Ali]

malesef bazen sonsuz bir döngüye giriyor, sayfanın son satırına kadar yazıyor (c deki bitiş tarihini dikkate almıyor) bazen hiç çalışmıyor. Sizide yordum kusurua bakmayın eski sistem elle girmeye devam anlaşılan

Örnek dosyanız baz alındığında yukarıdaki kod ile bu söylediklerinizin olması mümkün değil.
Gerçek dosyanızın örnek dosyanızdan farklı olduğunu düşünüyorum.
Eğer gerçek dosyanızı paylaşırsanız sorunu çözmeye çalışırım.
Aksi halde iyi çalışmalar.

 

[meleklerim]

Muzaffer Bey, günaydın.
Öncelikle hatanın nereden kaynaklandığını sanırım buldum. Normal kendisinin eklendiği excel sayfasında dediğiniz gibi çalışıyor. Ben userform üzerinden çalıştırmaya çalışınca ortalık karışıyor. . Bu kodlardaki tüm satır ve sütunların çalışacağı sayfaların adını ekleyip güncelleme şansımız var mı? Yani mesala
Range("D2: D" & Rows.Count).ClearContents satırını
Worksheets ("sheets12").Range(".........).ClearContens gibi

Ya da bu makroyu userformda kullanabileceğim başka bir öneriniz?

Çok yordum hakkınızı helal edin, selamlar
@Muzaffer Ali

 

[modoste]

formülle çözüm yapabilir miyiz sayın hocalarım

 

[meleklerim]

kodun d2 sütunu seçmeden önce başına Sheets("Tatil").Select ekleyince "Tatil" adlı sayfada çalıştı. Emeği geçen ilgilenen herkese çok teşekkür ederim
-----
Sub Test()
Dim Bak As Integer
Dim Satir As Integer
Dim Fark As Long
Dim BakFark As Long
Sheets("Tatil").Select
Range("D2" & Rows.Count).ClearContents
For Bak = 2 To Cells(Rows.Count, "B").End(xlUp).Row
Satir = Cells(Rows.Count, "D").End(xlUp).Row + 1
Cells(Satir, "D") = FormatDateTime(CDate(Cells(Bak, "B")), vbShortDate)
If Not Cells(Bak, "C") = "" Then
Fark = Cells(Bak, "C") - Cells(Bak, "B")
For BakFark = Satir + 1 To Satir + Fark
Cells(BakFark, "D") = FormatDateTime(1 + CDate(Cells(BakFark - 1, "D")), vbShortDate)
Next
End If
Next

MsgBox "Tamamlandı."
End Sub
-----