2 tarih aralığındaki gün sayısı kadar satır oluşturma

[akzc1]

2 tarih aralığındaki gün sayısı kadar altalta satır oluşturmak istiyorum. Yardımcı olabilirseniz sevinirim.

 

[Necdet]

Merhaba,

Tarihler hangi hücrelerde yazıyor? hangi satırlar arasında boş satır açılacak?

Bence siz örnek bir dosya ile sorunuzu destekleyin ki gereksiz yazışmalar oluşmasın.

 

[akzc1]

Eksik yazmışım.
Diyelim 1 satır da sütunlara veri girdim.( Adı/1.ay/2.ay/3.ay/tarih 1/tarih 2...şeklideki satırı doldurdum).tarih 1 ile tarih 2 arasındaki gün sayısı kadar aynı satırdan oluşmasını istiyorum.(girdiğim değerlerin aynısından oluşan satırdan, aradaki gün sayısı kadar oluşsun)
Umarım açık anlatabilmişimdir. Dosya yükleyemiyorum.

 

[akzc1]

yardımcı olabilecek misiniz? Acil gerekiyor!!!

 

[Necdet]

Merhaba,

Sorunuzu tam anlamamakla birlikte aşağıdaki kodları deneyiniz.

Kodlar ilgili sayfanın kod bölümünde olmalı. F sütununa tarih girdiğinde otomatik çalışacaktır.

Private Sub Worksheet_Change(ByVal Target As Range)
On Error GoTo Son
If Intersect(Target, [F:F]) Is Nothing Then Exit Sub
Dim i As Long
i = Target - Target.Offset(0, -1)
Range("A2:F" & i + 2).FillDown
Son:
End Sub

 

[akzc1]

Yardımınız için çok teşekkür ederim. Ancak istediğim şekilde uyarlayamadım. ekte yapmak istediğim formatı gönderiyorum. (diğerinde sadece en üstteki tarihe göre yapıyor.Farklı tarihlerde olabilir.)
Şimdiden çok teşekkür ederim.
Umarım yardımcı olabilirsiniz.

 

[Necdet]

Merhaba,

Şöyle bir şey yapmaya çalıştım, umarım işinize yarar.

Kopyasını çıkartacağınız satırın bulunduğu herhangi bir hücreye çift tıklamanız yeterli.

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
    Dim i As Long
    i = Range("G" & Target.Row) - Range("F" & Target.Row)
    Rows(Target.Row).Copy
    Rows(Target.Row + 1 & ":" & Target.Row + i).Insert Shift:=xlDown
    Application.CutCopyMode = False
End Sub

 

[akzc1]

Öncelikle tekrar teşekkür ediyorum zaman ayırdığınız için;
bende neden hata veriyor debug dediğimde bu satırda hata veriyor.

Rows(Target.Row + 1 & ":" & Target.Row + i).Insert Shift:=xlDown

 

[akzc1]

Öncelikle tekrar teşekkür ediyorum zaman ayırdığınız için;
bende neden hata veriyor debug dediğimde bu satırda hata veriyor.

Rows(Target.Row + 1 & ":" & Target.Row + i).Insert Shift:=xlDown

Ayrıca Tarihlerde artmıyor. ben altlata açılan kayıtların başlangıç tarihlerininde 1 er artmasını istiyorum. Buna da Yardımcı olabilirseniz sanırım başka sorunum kalmayacak

 

[Necdet]

Ayrıca Tarihlerde artmıyor. ben altlata açılan kayıtların başlangıç tarihlerininde 1 er artmasını istiyorum. Buna da Yardımcı olabilirseniz sanırım başka sorunum kalmayacak

Böyle bir istek olmadığı için dikkate almamıştım

Aşağıdaki kodlar yine ilgili sayfanın kod bölümünde olmalı ve tarihler de mutlaka girilmelidir.

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
    Dim i As Long
    If Not Range("G" & Target.Row) > Range("F" & Target.Row) Then
        MsgBox "Fatura Dönem Bitiş Tarihi Başlangıç Tarihinden Büyük Olmalı", vbCritical, "Necdet YEŞERTENER - [URL="http://www.excel.web.tr/"]www.excel.web.tr[/URL]"
        Exit Sub
    End If
    i = Range("G" & Target.Row) - Range("F" & Target.Row)
    Rows(Target.Row).Copy
    Rows(Target.Row + 1 & ":" & Target.Row + i).Insert Shift:=xlDown
    Range("F" & Target.Row & ":F" & Target.Row + i).DataSeries Rowcol:=xlColumns, Type:=xlChronological, Date:= _
        xlDay, Step:=1, Trend:=False
    Application.CutCopyMode = False
End Sub

 

[akzc1]

Tekrar merhaba,

çift click olmadan yapma şansımız var mı ? benim listem çok uzun hepsine teker teker tıklamam çok zor hatta imkansız!!!
Birde ben sizin gönderdiğiniz excel dosyasından başka dosyada kodu çalıştıramıyorum ve sizin gönderdiğinizde de koda erişemiyorum, boşmuş gibi görünüyor ama çalışıyor. Ben mi beceremedim anlayamadım. (Excel de çok yeniyim
Tekrar teşekkür ediyorum...

 

[Necdet]

çift click olmadan yapma şansımız var mı ? benim listem çok uzun hepsine teker teker tıklamam çok zor hatta imkansız!!!
Birde ben sizin gönderdiğiniz excel dosyasından başka dosyada kodu çalıştıramıyorum ve sizin gönderdiğinizde de koda erişemiyorum, boşmuş gibi görünüyor ama çalışıyor. Ben mi beceremedim anlayamadım. (Excel de çok yeniyim
Tekrar teşekkür ediyorum...

Keşke Örnek dosyada listenizin uzun olduğunu söyleseydiniz, hem gereksiz emek hem de gereksiz zaman harcamazdık. Sizin de işiniz şimdiye kadar çoktan çözülürdü.

Madem daha önce girilmiş veriler üzerinde işlem yapacaksınız o zaman kodları bir modül üzerinde yapmalı.

Zaman ayırabilirsem sorununuzla ilgileneceğim.

Aşağıdaki kodları bir modülle ilişkilendiriniz.

Sub Gun_Kadar_Satir_Cogalt()
    Dim i   As Long, _
        j   As Integer
    
    With Application
        .ScreenUpdating = False
    End With
    
    For i = Cells(Rows.Count, "F").End(3).Row To 2 Step -1
        If Not Range("G" & i) > Range("F" & i) Then
            MsgBox i & ". Satırda Fatura Dönem Bitiş Tarihi Başlangıç Tarihinden Büyük Değil", vbCritical, "Necdet YEŞERTENER - [URL="http://www.excel.web.tr/"]www.excel.web.tr[/URL]"
        Else
            j = Range("G" & i) - Range("F" & i) - 1
            Rows(i).Copy
            Rows(i & ":" & i + j).Insert Shift:=xlDown
            Range("F" & i & ":F" & i + j + 1).DataSeries Rowcol:=xlColumns, Type:=xlChronological, Date:= _
                xlDay, step:=1, Trend:=False
        End If
    Next i
    
    With Application
        .ScreenUpdating = True
        .CutCopyMode = False
    End With
    MsgBox "İşlem Tamamlanmıştır....", vbInformation, "Necdet YEŞERTENER - [URL="http://www.excel.web.tr/"]www.excel.web.tr[/URL]"
    
End Sub

 

[akzc1]

Yardımlarınız için çook teşekkür ederim. Vaktinizi fazlaca aldım kusura bakmayın. Ama sorun çözüldü. Tekrar çok teşekkür ederim..

 

[Necdet]

Merhaba,

Sorununuzun çözüldüğüne sevindim. Güle güle kullanınız.