Çözüldü Inputbox ile İki Kriterli Veri Oluşturma,

Mrexcel · 7 Haz 2020

Resimde paylaştığım şekilde günlük olarak veri bilgileri eklenmektedir. Sayfa1 de yer alan A sütunundaki Bölge ve F sütunundaki Arıza Tarihi bilgileri Inputbox seçeneği ile belirtip o bölgeye ait ve o tarihe ait verileri; başlıklar ile birlikte yeni bir excel dosyasıyla oluşturmasını istiyorum.

Oluşturulacak dosyanın yolu: Masaüstü/Bölge Araç Servis Takibi
Inputbox ile Bölgesi belirtilen ancak Arıza tarihi girilmemesi durumunda da o bölgeye ait tüm verilerin aktarılmasını istiyorum. Konu hakkında yardımlarınızı talep ediyorum. Teşekkürler.

Kısaca Excel bilgisi başlangıç seviyesinde kişilere ileteceğimden dolayı basit şekilde "sayfadaki butona bas karşına ekran gelecek oraya bölgeni yaz. daha sonra tekrar gelen alana Hangi tarihi istiyorsan onu yaz dosya ortak klasörün içerine bölge ismi ile oluşacak" demem gerekiyor.

İndir Dosya xlsm

Mrexcel · 8 Haz 2020

Merhaba;
Kod @Korhan AYHAN Bey tarafından hazırlanmıştır. Sorun çözüldü sadece ufak bir kod revize talebinde bulunulmuştur.

PHP:

Option Explicit

Sub Aktar()
    Dim Yol As String, S1 As Worksheet, S2 As Worksheet, Veri As Variant
    Dim Kriter As Variant, K1 As Workbook, Son As Long
  
    Veri = Application.InputBox("Bölge adını ve arıza tarihini giriniz!" & _
             Chr(10) & Chr(10) & "Örnek ; ANKARA,01.06.2020 11:00:00", "KRİTER GİRİŞİ")
          
    If Veri = "" Or Veri = False Then Exit Sub
  
    Set S1 = Sheets("Sayfa1")
  
    Yol = CreateObject("WScript.Shell").SpecialFolders("Desktop") & Application.PathSeparator & "Bölge Araç Servis Takibi"
    If Dir(Yol, vbDirectory) = "" Then MkDir (Yol)
  
    If InStr(1, Veri, ",") = 0 Then Veri = Veri & ","

    Kriter = Split(Veri, ",")
  
    On Error Resume Next
    S1.ShowAllData
    On Error GoTo 0
  
    With S1
        .Range("A1").AutoFilter 1, Kriter(0)
        If Kriter(1) <> "" Then .Range("A1").AutoFilter 6, Array(2, Format(CDate(Kriter(1)), "dd/mm/yyyy hh:mm"))
        Son = .Cells(.Rows.Count, 1).End(3).Row
        If Son > 1 Then
            Set K1 = Workbooks.Add(1)
            Set S2 = K1.Sheets(1)
            .Range("A1").CurrentRegion.Copy S2.Range("A1")
            S2.Columns.AutoFit
            Application.DisplayAlerts = False
            K1.SaveAs Yol & Application.PathSeparator & Kriter(0) & ".xlsm", 52
            K1.Close
            Application.DisplayAlerts = True
            .ShowAllData
            MsgBox "Aktarım işlemi tamamlanmıştır.", vbInformation
        Else
            .ShowAllData
            MsgBox "Aradğınız kriter bulunamadı!", vbCritical
        End If
    End With

    Set S1 = Nothing
    Set S2 = Nothing
    Set K1 = Nothing
End Sub

Çözüldü Inputbox ile İki Kriterli Veri Oluşturma,

Mrexcel

Mrexcel