sütun ekleme ve çıkarma

[uzmanamele]

merhaba
örnek dosya sayfa2 de başlangıç için 12 aylık süre için gerekli sütunlar mevcut.
girilen tarih aralığı 12 aydan küçükse sütun sayısı değişmesin ama her fazla ay için sayfa2 de yeni ay sütunu nasıl ekleriz?
18 ay için 6 ay sütunu eklediğimizde sonradan 14 ay için işlem yapmak istediğimizde de artan 4 ay sütununu silmesi gerekiyor.

 

[Levent Menteşoğlu]

Dosyanızdaki kodu aşağıdaki ile değiştirerek denermisiniz.

Public Sub Sayfa2_Tarih()
Dim i As Date
[BB16:IV25].Delete Shift:=xlToLeft
If Round((CLng([c5]) - CLng([c4])) / 30, 0) > 12 Then
[J16:IV25].Delete Shift:=xlToLeft
aysayisi = 4 * Round((CLng([c5]) - CLng([c4])) / 30, 0) + 9
[F16:I25].AutoFill Destination:=Range("F16", Cells(25, aysayisi)), Type:=xlFillDefault
End If
j = 2
i = [c4]
Range("F16:IV16").ClearContents   'ayın ilk günü satırı
Range("F17:IV16").ClearContents   'haftanın ilk günü satırı
Range("F21:IV21").ClearContents   'ayın son günü satırı
Range("F22:IV22").ClearContents 'haftanın son günü satırı
Do While i <= [c5]
    j = j + 4
    Cells(16, j) = DateSerial(Year(i), Month(i), 1)     'ay&#305;n ilk g&#252;n&#252;
    Cells(21, j) = DateSerial(Year(i), Month(i) + 1, 0) 'ay&#305;n son g&#252;n&#252;
    
        Cells(17, j) = DateSerial(Year(i), Month(i), 1)          '1.haftan&#305;n ilk g&#252;n&#252;
        Cells(17, j + 1) = DateSerial(Year(i), Month(i), 1) + 7  '2.haftan&#305;n ilk g&#252;n&#252;
        Cells(17, j + 2) = DateSerial(Year(i), Month(i), 1) + 14 '3.haftan&#305;n ilk g&#252;n&#252;
        Cells(17, j + 3) = DateSerial(Year(i), Month(i), 1) + 21 '4.haftan&#305;n ilk g&#252;n&#252;
     
            Cells(22, j) = DateSerial(Year(i), Month(i), 1) + 6      '1.haftan&#305;n son g&#252;n&#252;
            Cells(22, j + 1) = DateSerial(Year(i), Month(i), 1) + 13 '2.haftan&#305;n son g&#252;n&#252;
            Cells(22, j + 2) = DateSerial(Year(i), Month(i), 1) + 20 '3.haftan&#305;n son g&#252;n&#252;
            Cells(22, j + 3) = DateSerial(Year(i), Month(i) + 1, 0)  '4.haftan&#305;n son g&#252;n&#252;
    i = DateSerial(Year(i), Month(i) + 1, 1)
Loop
End Sub

 

[uzmanamele]

merhaba
syn Levent Menteşoğlu,
kodlardaki değişiklik için çok teşekkürler, asıl dosyaya adapte etmeye çalışacağım.
başlangıçta kaç sayfa ve her sayfada kaç sütun olacağı kestirilemediğinden dosya boyutu 30 Mb'ı aşıyordu. bu kodları uyarladıktan sonra satır sayısınıda optimize edebilirsem dosya boyutunu 7-8 Mb'a kadar düşürebilirim.
tekrar çok teşekkür ederim.

 

[kemalist]

dosyanızdaki kodu aşağıdaki ile değiştirerek denermisiniz.

public sub sayfa2_tarih()
dim i as date
[bb16:ıv25].delete shift:=xltoleft
ıf round((clng([c5]) - clng([c4])) / 30, 0) > 12 then
[j16:ıv25].delete shift:=xltoleft
aysayisi = 4 * round((clng([c5]) - clng([c4])) / 30, 0) + 9
[f16:ı25].autofill destination:=range("f16", cells(25, aysayisi)), type:=xlfilldefault
end ıf
j = 2
i = [c4]
range("f16:ıv16").clearcontents   'ayın ilk günü satırı
range("f17:ıv16").clearcontents   'haftanın ilk günü satırı
range("f21:ıv21").clearcontents   'ayın son günü satırı
range("f22:ıv22").clearcontents 'haftanın son günü satırı
do while i <= [c5]
    j = j + 4
    cells(16, j) = dateserial(year(i), month(i), 1)     'ayın ilk günü
    cells(21, j) = dateserial(year(i), month(i) + 1, 0) 'ayın son günü
    
        cells(17, j) = dateserial(year(i), month(i), 1)          '1.haftanın ilk günü
        cells(17, j + 1) = dateserial(year(i), month(i), 1) + 7  '2.haftanın ilk günü
        cells(17, j + 2) = dateserial(year(i), month(i), 1) + 14 '3.haftanın ilk günü
        cells(17, j + 3) = dateserial(year(i), month(i), 1) + 21 '4.haftanın ilk günü
     
            cells(22, j) = dateserial(year(i), month(i), 1) + 6      '1.haftanın son günü
            cells(22, j + 1) = dateserial(year(i), month(i), 1) + 13 '2.haftanın son günü
            cells(22, j + 2) = dateserial(year(i), month(i), 1) + 20 '3.haftanın son günü
            cells(22, j + 3) = dateserial(year(i), month(i) + 1, 0)  '4.haftanın son günü
    i = dateserial(year(i), month(i) + 1, 1)
loop
end sub

levent bey benim isteğim butona basılıp sütun eklenirken 3.satırın sabit kalmalı.bunula ilgili makroda nasıl bir değişiklik yapılabilir.örnek denem dosyası ektedir.yardımlarınız için şimdiden teşekkür ederim...