Kapalı Çalışma Kitabından Tarih Aralığına Göre Veri Alma Kod Yardımı

[Believing]

Sayın Uzman Arkadaşlar,

Ekteki çalışamada bir işletim siteminden oluşturulmuş, "KAPALI" isminde çalışma kitabı ile "AÇIK" isimli çalışma kitabı bulunmaktadır. Adından da anlaşılacağı gibi "KAPALI" isimli kitap açılmaksızın, "AÇIK" işimli çalışma kitabına veri tarnsferi yapmak istiyorum. "AÇIK" isimli çalışma kitabına bir "CommandButton.1" butonu oluşturdum. "E1" hücresinde Başlangış tarihi "E2" hücresinde ise bitiş tarihi bulunmatadır. CommandButton.1'e basılınca iki tarih aralığına göre, "KAPALI" isimli çalışma kitabındaki verilerin aralarında boş satır bulunmaksızın, "AÇIK" isimli çalışma katabına transferinin yapılmasını sağlamak istiyorum.
Kod konusunda siz değerli uzman arakadaşların benim için değerli yardımlarını rica ediyorum.

Saygılarımla,
Ömer Ali ÜZÜMCÜ

LİNK;
http://s7.dosya.tc/server8/nu6qr2/KAPALI_DOSYA_UYGULAMASI.rar.html
http://dosya.co/vtj7bboyx9wz/KAPALI_DOSYA_UYGULAMASI.rar.html

 

[Ömer BARAN]

Merhaba.

Aç, verileri al ve kapat yöntemiyle aşağıdaki gibi sonuç alabilirsiniz.

>> Alt taraftan Veritabanı sayfasının adına fareyle sağ tıklayıp KOD GÖRÜNTÜLEyi seçerek VBA ekranını açın ve
aşağıdaki kodu sağ taraftaki boş alana yapıştırın.

Private Sub CommandButton1_Click()
    BARAN_KAPALIDAN_AL
End Sub

-- VBA ekranında, üst taraftaki MENÜ çubuğundan INSERT=>MODULEyi seçip, sağ taraftaki boş alana da aşağıdaki kod blokunu yapıştırın.

Sub BARAN_KAPALIDAN_AL()
Set ana = ThisWorkbook
If ana.Sheets("Veritabanı").[E1] = "" Or ana.Sheets("Veritabanı").[E2] = "" Or _
    ana.Sheets("Veritabanı").[E1] > ana.Sheets("Veritabanı").[E2] Then
    MsgBox "H A T A :" & vbLf & "-- Başlangıç ve bitiş tarihleri boş bırakılamaz," & vbLf & _
        "-- Başlangıç tarihi, bitiş tarihinden büyük olamaz.", vbCritical, "..:: Ömer BARAN ::.."
   Exit Sub
End If
Set kapali = Workbooks.Open(ThisWorkbook.Path & "/" & "DATA_KAPALI.xls")
Application.ScreenUpdating = False: Application.DisplayAlerts = False
If ana.Sheets("Veritabanı").Cells(Rows.Count, 1).End(3).Row > 3 Then _
    ana.Sheets("Veritabanı").Range("A4:K" & Rows.Count).ClearContents
    bas = CLng(ana.Sheets("Veritabanı").[E1])
    bit = CLng(ana.Sheets("Veritabanı").[E2])
    ActiveWorkbook.Sheets("Sheet1").Range("A1:L" & Rows.Count).AutoFilter Field:=1, Criteria1:= _
        ">=" & bas, Operator:=xlAnd, Criteria2:="<=" & bit
        If kapali.Sheets("Sheet1").Cells(Rows.Count, 1).End(3).Row > 1 Then
            kapali.Sheets("Sheet1").Range("A2:K" & Rows.Count).SpecialCells(xlCellTypeVisible).Copy _
                ana.Sheets("Veritabanı").[A4]
        End If
ActiveSheet.Range("A1:L" & Rows.Count).AutoFilter Field:=1
kapali.Close 0
Application.DisplayAlerts = True: Application.ScreenUpdating = True
If ana.Sheets("Veritabanı").Cells(Rows.Count, 1).End(3).Row = 3 Then
    MsgBox "Kapalı belgede, belirtilen tarih aralığında veri yok.", vbInformation, "..:: Ömer BARAN ::.."
Else
    MsgBox "Veriler aktarıldı.", vbInformation, "..:: Ömer BARAN ::.."
End If
End Sub

 

[Haluk]

Merhaba;

Alternatif olarak aşağıdaki ekli dosyada yer alan kod da kullanılabilir.

.