Sutundaki değerlere göre tarih vermek

[cyperin]

Merhaba;
Elimizde yaklaşık 9.000 satırlık ve bu satırlara ait 8-9 sutunluk veri bulunmaktadır. Bu satırlarda bize ihtiyaç olan rakamların belli toplamlarına tarih vermektir. Yapacağımız iş şu şekildedir biz kişi listesini bir sıraya sokmak istiyoruz bir işletmemiz var ve insanlara sen şu tarih de gel sen şu tarih de gel demek istiyoruz işletmenin belli bir kapasitesi var günlük 6 ton gibi ve bu müşterilerin bizden alacakları var bunları teslim etmemiz lazım ama 6 tondan fazla günlük ödeme yapamıyoruz. Bunu nasıl tarihlendirebilirim. Yardımcı olursanız beni büyük bir yükten kurtaracaksınız. Çok Teşekkür Ederim.

 

[Necdet]

Merhaba,

Örnek dosyanızı paylaşım sitelerinden birine ekleyiniz, daha hızlı yardım alabilirsiniz.

 

[cyperin]

http://s5.dosya.tc/server3/6qhc56/Ornek.xlsx.html

Yukarıda örnek dosya eklidir. F sutunundaki değerler baz alınarak mesela 60 rakamı elde edilince 01.07.2015 tekrar o değerler toplama dahil edilmeden 60 rakamı elde edilince 02.07.2015 diye otomatik olarak her 60 rakamı elde edildikçe tarih vermesini istiyorum sıra önemli değil yani 1. sütundan 12 rakamına ve 508. sütundan 15 rakamına da aynı tarihi verebilir yani sütunlarda tarih sırası olmasına gerek yok benim için önemli olan toplam aynı tarih içinde 60 sayısının elde edilmesi.

 

[cyperin]

Bu konuda yardımcı olabilecek arkadaş yok mu? Çok uzun bir işlem var bilginiz varsa yardımcı olun lütfen.

 

[veyselemre]

60'a tamamlayacak rakam kalmayınca eksik bırakır.

Sub planla()
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
    tar = "30.06.2015"
    son = [f65536].End(3).Row
    renk = 3
    [g2:j65536].ClearContents
    [A2:j65536].Interior.ColorIndex = xlNone

    For Each elm In Range("H2.H" & son)
        If elm.Value = "" Then elm.Offset(0, -1).Value = elm.Offset(0, -2).Value
    Next elm
basla:
    If [g2] > 0 Then bas = 2 Else bas = [g1].End(xlDown).Row
    son = [g65536].End(3).Row
    If bas > son Then GoTo atla2
    For i = bas To son

        Application.Goto Cells(i + 8, "H")
        topla = 0
        For ii = bas To son
            If Cells(ii, "G") = "" Then GoTo atla1
            kalan = 60 - topla
            If kalan >= Cells(ii, "G") Then topla = topla + Cells(ii, "G"): Cells(ii, "I") = "*"
            If topla = 60 Then Exit For
atla1:
        Next ii

        tar = DateAdd("d", 1, tar)
        For Each elm In Range("I2:I" & son).SpecialCells(xlCellTypeConstants, 23)
            elm.Offset(0, -1) = tar
            elm.Offset(0, -2) = ""
            Cells(elm.Row, 1).Resize(1, 8).Interior.ColorIndex = renk
        Next elm
        [I2:I65536].ClearContents
        renk = renk + 2: If renk = 57 Then renk = 3
        GoTo basla
    Next i
atla2:
    Application.ScreenUpdating = True
    Application.Calculation = xlCalculationAutomatic
End Sub

 

[Korhan Ayhan]

Alternatif;

Süreyi biraz kısaltmaya çalıştım...

Option Explicit

Sub Tarih_Ver()
    Dim Tarih As Date, Miktar As Integer, Son As Long, Aralik As Range, Miktar_Araligi As Range
    Dim X As Long, Y As Long, Toplam As Long, Kalan As Long, Zaman As Double, Veri As Range
    Dim Bul As Range, Adres As String, Alan As Range, Satir As Long, Say As Long
    
    Zaman = Timer
    
    With Application
        .ScreenUpdating = False
        .Calculation = xlCalculationManual
        .EnableEvents = False
    End With
    
    Tarih = DateSerial(2015, 7, 1)
    Miktar = 60
    
    On Error Resume Next
    ActiveSheet.ShowAllData
    On Error GoTo 0
    
    Son = Cells(Rows.Count, "F").End(3).Row
    Range("G:G").ClearContents
    
    On Error Resume Next
    Set Miktar_Araligi = Columns("F:F").SpecialCells(xlCellTypeConstants, 23)
    On Error GoTo 0
        
10  For Each Veri In Miktar_Araligi
        Cells(1, "G") = Veri.Row
        If Cells(Veri.Row, "G") = "" Then
            For Y = Veri.Row To Son
                If Toplam = Miktar Then
                    Cells(Y, "G") = Tarih
                Else
                    If Cells(Y, "G") = "" Then
                        Cells(Y, "G") = "+++"
                        Toplam = Toplam + Cells(Y, "F")
                        Kalan = Miktar - Toplam
                        
                        If Alan Is Nothing Then
                            Set Alan = Cells(Y, "G")
                        Else
                            Set Alan = Application.Union(Alan, Cells(Y, "G"))
                        End If
                        
                        On Error Resume Next
                        Set Aralik = Columns("G:G").SpecialCells(xlCellTypeBlanks)
                        On Error GoTo 0
                        
                        If Not Aralik Is Nothing Then
                            Set Bul = Aralik.Offset(0, -1).Find(Kalan, , , xlWhole)
                            If Not Bul Is Nothing Then
                                Adres = Bul.Address
                                Do
                                    If Cells(Bul.Row, "G") = "" Then
                                        Cells(Bul.Row, "G") = "+++"
                                        Toplam = Toplam + Cells(Bul.Row, "F")
                                        If Alan Is Nothing Then
                                            Set Alan = Bul.Offset(0, 1)
                                        Else
                                            Set Alan = Application.Union(Alan, Bul.Offset(0, 1))
                                        End If
                                        Exit Do
                                    End If
                                    Set Bul = Aralik.Offset(0, -1).FindNext(Bul)
                                Loop While Not Bul Is Nothing And Bul.Address <> Adres
                                
                                If Not Alan Is Nothing And Toplam = Miktar Then
                                    Alan = Tarih
                                    Tarih = Tarih + 1
                                    GoTo 20
                                Else
                                    Alan.ClearContents
                                End If
                            End If
                        End If
                    End If
                End If
            Next
        End If
20
        Adres = ""
        Kalan = 0
        Toplam = 0
        Range("G:G").Replace "+++", Empty
        Set Aralik = Nothing
        Set Bul = Nothing
        Set Alan = Nothing
    Next

    Say = WorksheetFunction.CountIf(Range("G2:G" & Son), "")
    Toplam = WorksheetFunction.SumIf(Range("G2:G" & Son), "", Range("F2:F" & Son))
    
    On Error Resume Next
    Set Miktar_Araligi = Columns("G:G").SpecialCells(xlCellTypeBlanks)
    On Error GoTo 0
    
    If Say > 0 And Toplam >= Miktar Then
        If Not Miktar_Araligi Is Nothing Then GoTo 10
    Else
        If Not Miktar_Araligi Is Nothing Then Miktar_Araligi = Tarih
    End If
    
    Set Miktar_Araligi = Nothing
    
    With Application
        .ScreenUpdating = True
        .Calculation = xlCalculationAutomatic
        .EnableEvents = True
    End With

    MsgBox "İşleminiz tamamlanmıştır." & Chr(10) & "İşlem süresi ; " & Format(Timer - Zaman, "0.00"), vbInformation
End Sub

 

[cyperin]

Ben bu yazdığınız kodları nereye yazacağım?

 

[Korhan Ayhan]

Dosyayı açın.
ALT+F11 tuşlarına basın.
Açılan pencerede INSERT menüsüne tıklayın ve MODULE seçeneğini seçin.
Sağ tarafta beyaz renkli bir alan açılacaktır.

O bölüme verdiğimiz kodu uygulayın.

Excel sayfasına geri dönün. Sayfanıza EKLE menüsünden bir şekil ekleyin. Şeklin üzerinde sağ klik yapın ve makro ata seçeneği ile yazılan makroyu şekle tanımlayın.

Daha sonra dosyanızı "Makro içerebilen dosya" şeklinde kayıt edin.

Dosyanızı tekrar açın.

Şekle tıkladığınızda işlemler yapılacaktır.

Not: Dosyanızı açarken bilgilendirme şeridinde size güvenlikle ilgili uyarı verecektir. Bu uyarılara evet diyerek etkinleştirmeniz gerekiyor.

 

[cyperin]

Cevap verdiğiniz için çok teşekkür ederim. Dediklerinizi harfiyen yaptım ve tekrar açtığımda şekle tıkladım imleç dönmeye başladı ve bir pencerede işlem tamamlanmıştır süre 27,33 gibi bir ifade çıktı ve sayfada hiçbir değişiklik olmadı.

 

[cyperin]

İlk makro çalıştı ikinci verdiğiniz makro çalışmadı; ve şunu sormak istiyorum be sutun olarak ekleme yaptığımda örnek dosyada veriler H sutunundadı bu verileri K sutununa taşıdığımda yine bu makro çalışacak mı ve esas çalışmak istediğim dosyada INSERT menüsünde hiçbir tuş aktif değil bunu nasıl çözerim.

 

[Korhan Ayhan]

Önerilen kodlarda sütun bilgileri sabittir. Sizin asıl dosyanızda ilgili sütun farklı yerde ise kodu revize etmek gerekir.

 

[cyperin]

Peki INSERT menüsündeki simgeleri nasıl aktif hale getirebilirim Gerçek dosyamda bu aktif değil.

 

[cyperin]

INSERT menüsünü başka exel sayfası açınca aktif ettim sorun kalmadı uygulamaya başlıyayım takıldığım yer olursa sorarım. Verdiğiniz bilgiler ve yaptığınız Makrolar için çok teşekkür ederim.

 

[cyperin]

Dün yazmıştım ama mesaj hakkım dolduğu için gitmedi galiba. Sayın Korhan Ayhan Hocam, Sayın Necdet Yeşertener Hocam ve veyselemre Hocam verdiğiniz cevaplar için çok teşekkür ederim. INSERT sorununu da yeni bir exel açarak çözdüm sorun kalmadı.

 

[cyperin]

Sayın Hocalarım yazdığınız kodlar çok işime yaradı fakat tarih verirken sırayla vermektedir. Tarihleri dağınık vermesini istiyorum. Bir kişinin ürünü bir günde değil değişik günlerde çıksın. Yani toplamı 60 ton olan tarihler alt alta satırlarda değil değişik değiş satırlardan oluşmasını istiyorum. Yardımlarınız için çok teşekkür ederim.

 

[veyselemre]

Sub planla()
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
    tar = "30.06.2015"
    son = [f65536].End(3).Row
    Range("G:K").ClearContents
    Range("J1:K1") = Array("S.No1", "S.No2")
    Range("J2:K2") = 1
    Range("J2:K" & son).DataSeries
    For i = 2 To son
        say = i + Round(Rnd() * 150, 0)
        If say > son Then say = son
        tmp = Cells(i, "K")
        Cells(i, "K") = Cells(say, "K")
        Cells(say, "K") = tmp
    Next i
    Columns("A:K").Sort Key1:=Range("K2"), Order1:=xlAscending, Header:=xlYes
    Range("G2:G" & son).Value = Range("F2:F" & son).Value
basla:
    If [g2] > 0 Then bas = 2 Else bas = [g1].End(xlDown).Row
    son = [g65536].End(3).Row
    If bas > son Then GoTo atla2
    For i = bas To son

        Application.Goto Cells(i + 8, "H")
        topla = 0
        For ii = bas To son
            If Cells(ii, "G") = "" Then GoTo atla1
            kalan = 60 - topla
            If kalan >= Cells(ii, "G") Then topla = topla + Cells(ii, "G"): Cells(ii, "I") = "*"
            If topla = 60 Then Exit For
atla1:
        Next ii
        tar = DateAdd("d", 1, tar)
        For Each elm In Range("I2:I" & son).SpecialCells(xlCellTypeConstants, 23)
            elm.Offset(0, -1) = tar
            elm.Offset(0, -2) = ""
        Next elm
        [I2:I65536].ClearContents
        GoTo basla
    Next i
atla2:
    Columns("A:K").Sort Key1:=Range("J2"), Order1:=xlAscending, Header:=xlYes
    Range("I:K").ClearContents
    Application.ScreenUpdating = True
    Application.Calculation = xlCalculationAutomatic
End Sub

 

[Korhan Ayhan]

Veysel bey sizin kodunuzu denediğimde bazı tarihlerin toplamı 60 değerini vermiyor. Yaklaşık 500 satır falan civarında bu şekilde veri oluşuyor.

Bende önerdiğim kodu son isteğinize göre revize ettim.

Deneyiniz...

Tarihleri "H" sütununa listeler.

Option Explicit

Sub Tarih_Ver()
    Dim Tarih As Date, Miktar As Integer, Son As Long, Aralik As Range, Miktar_Araligi As Range
    Dim X As Long, Y As Long, Toplam As Long, Kalan As Long, Zaman As Double, Veri As Range
    Dim Bul As Range, Adres As String, Alan As Range, Satir As Long, Say As Long, Sayi As Long
    
    Zaman = Timer
    
    With Application
        .ScreenUpdating = False
        .Calculation = xlCalculationManual
        .EnableEvents = False
    End With
    
    Tarih = DateSerial(2015, 7, 1)
    Miktar = 60
    
    On Error Resume Next
    ActiveSheet.ShowAllData
    On Error GoTo 0
    
    Son = Cells(Rows.Count, "F").End(3).Row
    Range("H:K").ClearContents
    
    Range("I1:J1") = Array("Sıralama-1", "Sıralama-2")
    Range("I2:J2") = 1
    Range("I2:J" & Son).DataSeries
    
    For X = 2 To Son
        Cells(X, "J") = Int((Son * Rnd) + 1)
    Next
    
    Range("A2:A" & Son).EntireRow.Sort Range("J2"), xlAscending
    
    On Error Resume Next
    Set Miktar_Araligi = Columns("F:F").SpecialCells(xlCellTypeConstants, 23)
    On Error GoTo 0
        
10  For Each Veri In Miktar_Araligi
        Cells(1, "H") = Veri.Row
        If Cells(Veri.Row, "H") = "" Then
            For Y = Veri.Row To Son
                If Toplam = Miktar Then
                    Cells(Y, "H") = Tarih
                Else
                    If Cells(Y, "H") = "" Then
                        Cells(Y, "H") = "+++"
                        Toplam = Toplam + Cells(Y, "F")
                        Kalan = Miktar - Toplam
                        
                        If Alan Is Nothing Then
                            Set Alan = Cells(Y, "H")
                        Else
                            Set Alan = Application.Union(Alan, Cells(Y, "H"))
                        End If
                        
                        On Error Resume Next
                        Set Aralik = Columns("H:H").SpecialCells(xlCellTypeBlanks)
                        On Error GoTo 0
                        
                        If Not Aralik Is Nothing Then
                            Set Bul = Aralik.Offset(0, -2).Find(Kalan, , , xlWhole)
                            If Not Bul Is Nothing Then
                                Adres = Bul.Address
                                Do
                                    If Cells(Bul.Row, "H") = "" Then
                                        Cells(Bul.Row, "H") = "+++"
                                        Toplam = Toplam + Cells(Bul.Row, "F")
                                        If Alan Is Nothing Then
                                            Set Alan = Bul.Offset(0, 2)
                                        Else
                                            Set Alan = Application.Union(Alan, Bul.Offset(0, 2))
                                        End If
                                        Exit Do
                                    End If
                                    Set Bul = Aralik.Offset(0, -2).FindNext(Bul)
                                Loop While Not Bul Is Nothing And Bul.Address <> Adres
                                
                                If Not Alan Is Nothing And Toplam = Miktar Then
                                    Alan = Tarih
                                    Tarih = Tarih + 1
                                    GoTo 20
                                Else
                                    Alan.ClearContents
                                End If
                            End If
                        End If
                    End If
                End If
            Next
        End If
20
        Adres = ""
        Kalan = 0
        Toplam = 0
        Range("H:H").Replace "+++", Empty
        Set Aralik = Nothing
        Set Bul = Nothing
        Set Alan = Nothing
    Next

    Say = WorksheetFunction.CountIf(Range("H2:H" & Son), "")
    Toplam = WorksheetFunction.SumIf(Range("H2:H" & Son), "", Range("F2:F" & Son))
    
    On Error Resume Next
    Set Miktar_Araligi = Columns("H:H").SpecialCells(xlCellTypeBlanks)
    On Error GoTo 0
    
    If Say > 0 And Toplam >= Miktar Then
        If Not Miktar_Araligi Is Nothing Then GoTo 10
    Else
        If Not Miktar_Araligi Is Nothing Then Miktar_Araligi = Tarih
    End If
    
    Set Miktar_Araligi = Nothing
    
    Range("A2:A" & Son).EntireRow.Sort Range("I2"), xlAscending
    
    Range("I:J").ClearContents
    
    With Application
        .ScreenUpdating = True
        .Calculation = xlCalculationAutomatic
        .EnableEvents = True
    End With

    MsgBox "İşleminiz tamamlanmıştır." & Chr(10) & "İşlem süresi ; " & Format(Timer - Zaman, "0.00"), vbInformation
End Sub