Parçalı Veri Aktarma

[baydeniro]

Merhaba arkadaşlar. Makro yardımı ile şu şekilde bir uygulamaya gereksinmemiz var. Sadece Tarihe göre çalışacak ve RAPOR sayfasına № sırasına göre sadece 15 adet veri atacak şekilde olmalı. Eğer aynı tarihte olan veri sayısı 15 ten fazla ise makro kaçıncı 15 lik dilimin aktarılmasının istendiğini sorarak o 15 lik dilimdeki verileri yine aynı yani 1. grup verilerin (RAPOR sayfasında bulunan eski verileri silmek kaydı ile) eski verilerin üstüne atmalı. Örnek dosya ektedir. Şimdiden teşekkürler.

 

[N.Ziya Hiçdurmaz]

yanıt

Private Sub ComboBox1_Change()
ComboBox1 = Format(ComboBox1, "DD.MM.YYYY")
End Sub
Private Sub ComboBox2_Change()
ComboBox2 = Format(ComboBox2, "DD.MM.YYYY")
End Sub
Private Sub CommandButton1_Click()
Set sd = Sheets("DATA")
Set sr = Sheets("RAPOR")
sr.Range("a2:f1000").Clear
For sira = 1 To [b65536].End(3).Row
Range("a" & sira + 1) = sira
Next
For sut = 2 To sd.[b65536].End(3).Row
tar1 = CLng(CDate(ComboBox1))
tar2 = CLng(CDate(ComboBox2))
If sd.Range("b" & sut) >= tar1 And sd.Range("b" & sut) <= tar2 Then
sd.Range("a" & sut & ":f" & sut).Copy
s = s + 1
sr.Range("a" & s + 1).PasteSpecial
Application.CutCopyMode = False
End If: Next
For sutr = 2 To sr.[b65536].End(3).Row
If WorksheetFunction.CountA(sr.[b2:b65536]) > 15 Then
MsgBox "Seçiminiz 15 Kaydı geçmektedir diğer dilimi seçiniz."
sr.Range("a2:f1000").Clear
Exit Sub
End If
Next
End Sub
Private Sub UserForm_Initialize()
ComboBox1.RowSource = "DATA!B2:B" & [b65536].End(3).Row
ComboBox2.RowSource = "DATA!B2:B" & [b65536].End(3).Row
End Sub

 

[veyselemre]

Sub dene()
    Set sd = Sheets("Data")
    Set sR = Sheets("Rapor")
    sd.Select

    sonB = [b65536].End(3).Row
    aktarilacakTarih = Application.InputBox("Aktarilacak tarihi sayfadan seçiniz", "Tarih seçimi", ActiveCell.Address, , , , , 8)
    say = WorksheetFunction.CountIf(Range("b2:b" & sonB), aktarilacakTarih)

    If say > 15 Then
        grupSay = WorksheetFunction.RoundUp(say / 15, 0)
yeniden:
        grup = Val(InputBox(grupSay & " grup vardır. Hangi grubu almas istiyorsunuz?"))
        If grup = 0 Or grup > grupSay Then GoTo yeniden
    Else
        grup = 1
    End If
    bas = ((grup - 1) * 15) + 1
    son = bas + 14
    If son > say Then son = say
    sat = 1
    sR.[A2:F16].ClearContents
    For x = 2 To sonB
        If Cells(x, 2) = aktarilacakTarih Then
            sirasi = sirasi + 1
            If sirasi >= bas And sirasi <= son Then
                sat = sat + 1
                sR.Range(sR.Cells(sat, 1), sR.Cells(sat, 6)).Value = Range(Cells(x, 1), Cells(x, 6)).Value
            ElseIf sirasi > son Then Exit For
            End If
        End If
    Next x
    sR.Select

End Sub

 

[baydeniro]

Sayın Veyselemre çok teşekkürler, çok güzel olmuş. Mümkünse 2 konuda kodu nasıl değiştirmem gerektiği konusunda yardımcı olabilir misiniz ?

1) Tarihi, RAPOR sayfası C1 hücresinden, Dilim No.sunu RAPOR sayfası C1 hücresinden F1 hücresinden kendisinin okumasını

2) Verilerin A2 hücresinden değil de A4 hücresinden başlayarak aktarılmasını sağlamak için nereyi değiştirmem gerekir.

 

[veyselemre]

Sub dene()
    Set sd = Sheets("Data")
    Set sr = Sheets("Rapor")
    sd.Select

    sonB = [b65536].End(3).Row
    'aktarilacakTarih = Application.InputBox("Aktarilacak tarihi sayfadan seçiniz", "Tarih seçimi", ActiveCell.Address, , , , , 8)
    aktarilacakTarih = sr.[c1]
    say = WorksheetFunction.CountIf(Range("b2:b" & sonB), aktarilacakTarih)

    If say > 15 Then
        grupSay = WorksheetFunction.RoundUp(say / 15, 0)
yeniden:
        'grup = Val(InputBox(grupSay & " grup vardır. Hangi grubu almas istiyorsunuz?"))
        grup = sr.[f1]
        
        If grup = 0 Or grup > grupSay Then GoTo yeniden
    Else
        grup = 1
    End If
    bas = ((grup - 1) * 15) + 1
    son = bas + 14
    If son > say Then son = say
    sat = 3
    sr.[A4:F18].ClearContents
    For x = 2 To sonB
        If Cells(x, 2) = aktarilacakTarih Then
            sirasi = sirasi + 1
            If sirasi >= bas And sirasi <= son Then
                sat = sat + 1
                sr.Range(sr.Cells(sat, 1), sr.Cells(sat, 6)).Value = Range(Cells(x, 1), Cells(x, 6)).Value
            ElseIf sirasi > son Then Exit For
            End If
        End If
    Next x
    sr.Select

End Sub

 

[baydeniro]

Çok Teşekkürler.

Çok teşekkürler sayın veyselemre. Şimdi harika oldu. Elleriniz dert görmesin.

 

[Ercan_ÇELİKOĞLU]

Afedersiniz

Sadece meraktan soruyorum dosyada 30.04.2007 ile 01.05.2007 tarih aralığını seçtim aktar dedim seçiminiz 15 dilimi geçiyor dedi peki sınırsız 1 seçim ypmak istesem? nasıl olacak?