Kapalı dosyadan buton ile veri alma.

Grknpkdzn · 13 Mayıs 2021

Korhan Ayhan' Alıntı:
Ben dosyanızı 2500 satırlık olacak şekilde düzenledim.

Sanırım bu haliyle yeterli olacaktır.

İşlem sonunda boş satırlar otomatik gizlenmektedir.

Korhan Bey,
Allah razı olsun. Ellerinize ve aklınıza sağlık.
Tekrar hayırlı bayramlar..

Grknpkdzn · 13 Mayıs 2021

Korhan Ayhan' Alıntı:
Ben dosyanızı 2500 satırlık olacak şekilde düzenledim.

Sanırım bu haliyle yeterli olacaktır.

İşlem sonunda boş satırlar otomatik gizlenmektedir.

Korhan Bey,
Şimdi dikkat ettim de, "G" ve "H" sütunlarına veriyi çekerken, başlangıç ve bitiş saatlerini garip bir şekilde gösteriyor.!
Yukarıdan "Sayı" olarak değiştiriyorum, "Genel" olarak değiştiriyorum ama misal başlangıç 16:00 bitiş 00:00 gibi göstermiyor.!
Bunu nasıl düzeltirim?
Kurcaladım ve İsteğe göre uyarlanmıştan->ss:dd yapınca düzeliyor. Bunu koda ekleyebilir miyiz?

Korhan Ayhan · 13 Mayıs 2021

Deneyiniz.

C++:

Option Explicit

Sub Mesai_Tablolarini_Iceri_Aktar()
    Dim Baglanti As Object, Kayit_Seti As Object
    Dim Sorgu As String, Yol As String, Dosya As String
    Dim Veri As Range, Alan As Range, Ay As String, Zaman As Double
    
    Zaman = Timer
    
    Application.ScreenUpdating = False
    
    Set Baglanti = CreateObject("Adodb.Connection")
    Set Kayit_Seti = CreateObject("Adodb.Recordset")
    
    Range("B7:K2506").ClearContents
    
    Cells.EntireRow.Hidden = False
    
    Ay = Range("K4").Value
    
    Yol = ThisWorkbook.Path & Application.PathSeparator
    
    Dosya = Dir(Yol & "*.xls*")
    
    While Dosya <> ""
        If UCase(Replace(Replace(Format(Split(Dosya, " ")(0), "mmmm"), "ı", "I"), "i", "İ")) = Ay Then
            Baglanti.Open "Provider=Microsoft.Ace.OleDb.12.0;Data Source=" & _
            Yol & Dosya & ";Extended Properties=""Excel 12.0;Hdr=No"""
            
            Sorgu = "Select * From [GÜNLÜK$B7:K]"
            
            Kayit_Seti.Open Sorgu, Baglanti, 1, 1
            
            If Kayit_Seti.RecordCount > 0 Then
                Cells(Rows.Count, "B").End(3)(2, 1).CopyFromRecordset Kayit_Seti
            End If
            
            
            If Kayit_Seti.State <> 0 Then Kayit_Seti.Close
            If Baglanti.State <> 0 Then Baglanti.Close
        End If
    
        Dosya = Dir
    Wend
    
    Range("G7:H2506").NumberFormat = "hh:mm:ss"
    
    Set Baglanti = Nothing
    Set Kayit_Seti = Nothing
    
    For Each Veri In Range("B7:B2506")
        If Veri.Value = "" Then
            If Alan Is Nothing Then
                Set Alan = Veri
            Else
                Set Alan = Union(Alan, Veri)
            End If
        End If
    Next
    
    If Not Alan Is Nothing Then Alan.EntireRow.Hidden = True
    
    Application.ScreenUpdating = True
    
    MsgBox "Veri aktarımı tamamlanmıştır." & vbCr & vbCr & _
           "İşlem süresi ; " & Format(Timer - Zaman, "0.00") & " Saniye", vbInformation
End Sub

Grknpkdzn · 13 Mayıs 2021

Korhan Ayhan' Alıntı:

Deneyiniz.

C++:

Option Explicit

Sub Mesai_Tablolarini_Iceri_Aktar()
    Dim Baglanti As Object, Kayit_Seti As Object
    Dim Sorgu As String, Yol As String, Dosya As String
    Dim Veri As Range, Alan As Range, Ay As String, Zaman As Double
   
    Zaman = Timer
   
    Application.ScreenUpdating = False
   
    Set Baglanti = CreateObject("Adodb.Connection")
    Set Kayit_Seti = CreateObject("Adodb.Recordset")
   
    Range("B7:K2506").ClearContents
   
    Cells.EntireRow.Hidden = False
   
    Ay = Range("K4").Value
   
    Yol = ThisWorkbook.Path & Application.PathSeparator
   
    Dosya = Dir(Yol & "*.xls*")
   
    While Dosya <> ""
        If UCase(Replace(Replace(Format(Split(Dosya, " ")(0), "mmmm"), "ı", "I"), "i", "İ")) = Ay Then
            Baglanti.Open "Provider=Microsoft.Ace.OleDb.12.0;Data Source=" & _
            Yol & Dosya & ";Extended Properties=""Excel 12.0;Hdr=No"""
           
            Sorgu = "Select * From [GÜNLÜK$B7:K]"
           
            Kayit_Seti.Open Sorgu, Baglanti, 1, 1
           
            If Kayit_Seti.RecordCount > 0 Then
                Cells(Rows.Count, "B").End(3)(2, 1).CopyFromRecordset Kayit_Seti
            End If
           
           
            If Kayit_Seti.State <> 0 Then Kayit_Seti.Close
            If Baglanti.State <> 0 Then Baglanti.Close
        End If
   
        Dosya = Dir
    Wend
   
    Range("G7:H2506").NumberFormat = "hh:mm:ss"
   
    Set Baglanti = Nothing
    Set Kayit_Seti = Nothing
   
    For Each Veri In Range("B7:B2506")
        If Veri.Value = "" Then
            If Alan Is Nothing Then
                Set Alan = Veri
            Else
                Set Alan = Union(Alan, Veri)
            End If
        End If
    Next
   
    If Not Alan Is Nothing Then Alan.EntireRow.Hidden = True
   
    Application.ScreenUpdating = True
   
    MsgBox "Veri aktarımı tamamlanmıştır." & vbCr & vbCr & _
           "İşlem süresi ; " & Format(Timer - Zaman, "0.00") & " Saniye", vbInformation
End Sub

Korhan Bey,
Son bir durum kalmış. Ekteki dosya da, "Hakettiği Mesai Saati" alanı doldurulurken yazının başına ( ' ) tek tırnak atıyor. Bundan dolayı da sizin yazdığınız kod ile data çektirdiğimde böyle başlayanları alamıyor. Bunu nasıl düzeltiriz? Bunun içinde ki kod, girilen her verinin otomatik büyük harfe döndürülmesi için yapılmıştı.!
_GÜNLÜK MESAİ TALEP FORMU.XLSB - 19 KB

Orion1 · 13 Mayıs 2021

Bir sütun ya string,ya sayı,yada tarih olmalıdır.
Bir sütunu böyle çorba gibi karıştırıp yaparsanız olmaz.
Exceli veri tabanı olarak kullanırsanız ado kurallarına uymalısınız.
Ayrıca veri tabanı olarak kullanırsanız.ado ile silme yapamazsınız.
Excel için bu geçerli.
Siz en iyisi veri tabanınızı access dosyasından yapınız.

Grknpkdzn · 13 Mayıs 2021

Orion1' Alıntı:
Bir sütun ya string,ya sayı,yada tarih olmalıdır.
Bir sütunu böyle çorba gibi karıştırıp yaparsanız olmaz.
Exceli veri tabanı olarak kullanırsanız ado kurallarına uymalısınız.
Ayrıca veri tabanı olarak kullanırsanız.ado ile silme yapamazsınız.
Excel için bu geçerli.
Siz en iyisi veri tabanınızı access dosyasından yapınız.

Sn. Orion1,
Bilgi, birikim ve tecrübenizi paylaştığınız için teşekkür ederim.
Peki son paylaşımımda ki yaşamış olduğum sıkıntıyı giderecek bir çözümünüz var mı?

Korhan Ayhan · 13 Mayıs 2021

Bu sembol kaynak dosyalarınızda var. Bundan dolayı aktarımla geliyor.

Grknpkdzn · 13 Mayıs 2021

Korhan Ayhan' Alıntı:
Bu sembol kaynak dosyalarınızda var. Bundan dolayı aktarımla geliyor.

Hocam neredekini kaldırmam gerekiyor?

Korhan Ayhan · 13 Mayıs 2021

Kaynak dosyalarınızdan kaldırırsanız sorun düzelecektir diye düşünüyorum.

Korhan Ayhan · 13 Mayıs 2021

Biraz uğraştırdı ama aşağıdaki kod ile o sorunda bende düzeldi görünüyor.

Sizde deneyip sonucu bildirirseniz sevinirim.

C++:

Option Explicit

Sub Mesai_Tablolarini_Iceri_Aktar()
    Dim S1 As Worksheet, S2 As Worksheet, Baglanti As Object, Kayit_Seti As Object
    Dim Sorgu As String, Yol As String, Dosya As String
    Dim Veri As Range, Alan As Range, Ay As String, Zaman As Double
    
    Zaman = Timer
    
    Application.ScreenUpdating = False
    
    Set S1 = Sheets("AYLIK")
    Set Baglanti = CreateObject("Adodb.Connection")
    Set Kayit_Seti = CreateObject("Adodb.Recordset")
    
    S1.Range("B7:K2506").ClearContents
    
    S1.Cells.EntireRow.Hidden = False
    
    Ay = S1.Range("K4").Value
    
    Yol = ThisWorkbook.Path & Application.PathSeparator
    
    Dosya = Dir(Yol & "*.xls*")
    
    While Dosya <> ""
        If UCase(Replace(Replace(Format(Split(Dosya, " ")(0), "mmmm"), "ı", "I"), "i", "İ")) = Ay Then
            Baglanti.Open "Provider=Microsoft.Ace.OleDb.12.0;Data Source=" & _
            Yol & Dosya & ";Extended Properties=""Excel 12.0;Hdr=No"""
            
            Sorgu = "Select Ucase(F1),Ucase(F2),F3,F4,F5,F6,F7,F8,Ucase(F9),Ucase(F10) From [GÜNLÜK$B7:K]"
            
            Kayit_Seti.Open Sorgu, Baglanti, 1, 1
            
            If Kayit_Seti.RecordCount > 0 Then
                S1.Cells(S1.Rows.Count, "B").End(3)(2, 1).CopyFromRecordset Kayit_Seti
            End If
            
            
            If Kayit_Seti.State <> 0 Then Kayit_Seti.Close
            If Baglanti.State <> 0 Then Baglanti.Close
        End If
    
        Dosya = Dir
    Wend
    
    S1.Range("G7:H2506").NumberFormat = "hh:mm:ss"
    
    Set Baglanti = Nothing
    Set Kayit_Seti = Nothing
    
    For Each Veri In S1.Range("B7:B2506")
        If Veri.Value = "" Then
            If Alan Is Nothing Then
                Set Alan = Veri
            Else
                Set Alan = Union(Alan, Veri)
            End If
        End If
    Next
    
    If Not Alan Is Nothing Then Alan.EntireRow.Hidden = True
    
    S1.Range("I7:I2506").Copy
    Set S2 = Worksheets.Add
    S2.Range("A1").PasteSpecial xlPasteValues
    S2.Range("A1:A2500").Copy S1.Range("I7")
    Application.DisplayAlerts = False
    S2.Delete
    Application.DisplayAlerts = True
    
    With S1.Range("I7:I2506")
        .Value = .Value
        .HorizontalAlignment = xlCenter
        .VerticalAlignment = xlCenter
        .Borders.LineStyle = 1
    End With
    
    Set S1 = Nothing
    Set S2 = Nothing
    
    Application.ScreenUpdating = True
    
    MsgBox "Veri aktarımı tamamlanmıştır." & vbCr & vbCr & _
           "İşlem süresi ; " & Format(Timer - Zaman, "0.00") & " Saniye", vbInformation
End Sub

Grknpkdzn · 13 Mayıs 2021

Korhan Ayhan' Alıntı:

Biraz uğraştırdı ama aşağıdaki kod ile o sorunda bende düzeldi görünüyor.

Sizde deneyip sonucu bildirirseniz sevinirim.

C++:

Option Explicit

Sub Mesai_Tablolarini_Iceri_Aktar()
    Dim S1 As Worksheet, S2 As Worksheet, Baglanti As Object, Kayit_Seti As Object
    Dim Sorgu As String, Yol As String, Dosya As String
    Dim Veri As Range, Alan As Range, Ay As String, Zaman As Double
  
    Zaman = Timer
  
    Application.ScreenUpdating = False
  
    Set S1 = Sheets("AYLIK")
    Set Baglanti = CreateObject("Adodb.Connection")
    Set Kayit_Seti = CreateObject("Adodb.Recordset")
  
    S1.Range("B7:K2506").ClearContents
  
    S1.Cells.EntireRow.Hidden = False
  
    Ay = S1.Range("K4").Value
  
    Yol = ThisWorkbook.Path & Application.PathSeparator
  
    Dosya = Dir(Yol & "*.xls*")
  
    While Dosya <> ""
        If UCase(Replace(Replace(Format(Split(Dosya, " ")(0), "mmmm"), "ı", "I"), "i", "İ")) = Ay Then
            Baglanti.Open "Provider=Microsoft.Ace.OleDb.12.0;Data Source=" & _
            Yol & Dosya & ";Extended Properties=""Excel 12.0;Hdr=No"""
          
            Sorgu = "Select * From [GÜNLÜK$B7:K]"
          
            Kayit_Seti.Open Sorgu, Baglanti, 1, 1
          
            If Kayit_Seti.RecordCount > 0 Then
                S1.Cells(S1.Rows.Count, "B").End(3)(2, 1).CopyFromRecordset Kayit_Seti
            End If
          
          
            If Kayit_Seti.State <> 0 Then Kayit_Seti.Close
            If Baglanti.State <> 0 Then Baglanti.Close
        End If
  
        Dosya = Dir
    Wend
  
    S1.Range("G7:H2506").NumberFormat = "hh:mm:ss"
  
    Set Baglanti = Nothing
    Set Kayit_Seti = Nothing
  
    For Each Veri In S1.Range("B7:B2506")
        If Veri.Value = "" Then
            If Alan Is Nothing Then
                Set Alan = Veri
            Else
                Set Alan = Union(Alan, Veri)
            End If
        End If
    Next
  
    If Not Alan Is Nothing Then Alan.EntireRow.Hidden = True
  
    S1.Range("I7:I2506").Copy
    Set S2 = Worksheets.Add
    S2.Range("A1").PasteSpecial xlPasteValues
    S2.Range("A1:A2500").Copy S1.Range("I7")
    Application.DisplayAlerts = False
    S2.Delete
    Application.DisplayAlerts = True
  
    With S1.Range("I7:I2506")
        .Value = .Value
        .HorizontalAlignment = xlCenter
        .Borders.LineStyle = 1
    End With
  
    Application.ScreenUpdating = True
  
    MsgBox "Veri aktarımı tamamlanmıştır." & vbCr & vbCr & _
           "İşlem süresi ; " & Format(Timer - Zaman, "0.00") & " Saniye", vbInformation
End Sub

Korhan hocam zahmet verdim sizlere hakkınızı helal edin lütfen.
Kodu denedim ama ne hikmetse ( ' ) olan bazı dosyadan alıyor, bazısından almıyor.
Merak ettiğim yukarıdaki cevabınız da kodun içinde var demişsiniz.
Aşağıdaki bu kodu düzeltebilirsek, sizin aylık için hazırlamış olduğunuz dosya sıkıntısız çalışıyor olacak..
KOD ŞU;
Private Sub Worksheet_Change(ByVal Target As Range)
On Error GoTo Son
If Intersect(Target, [B7:C40,J7:K40]) Is Nothing Then Exit Sub
Application.EnableEvents = False
Target = UCase(Replace(Replace(Target, "i", "İ"), "ı", "I"))
Son: Application.EnableEvents = True
End Sub
Not: İlla bu kod olmak zorunda değil.. Girilen verilerin, otomatik olarak BÜYÜKHARF e çeviren herhangi bir kod da işe yarayacaktır.

Korhan Ayhan · 13 Mayıs 2021

#30 nolu mesajıma verileri büyük harfe çeviren özelliği ekledim. Deneyiniz.

Grknpkdzn · 13 Mayıs 2021

Korhan hocam yine olmadı.
Sizden son bir şey rica ediyorum.
24 nolu mesajımda ekte bulunan dosyanın içerisinde bulunan tablonun sadece,
"B", "C", "J", ve "K" sütünlarında girilen verilerin büyük yazmasını sağlayacak kodu paylaşabilirseniz, sorunum kökten çözülmüş olacak ve sizi daha fazla zahmete sokmaktan kurtarıcam.
Bu kodu ben günlük dosyasına gireceğim için aylık dosyasını çalıştırdığımda sıkıntısız çekecektir diye düşünüyorum..
Sabrınız için gerçekten Allah razı olsun.

Korhan Ayhan · 13 Mayıs 2021

Olmadı dediğiniz dosyanızı paylaşırsanız hataya neyin sebep olduğunu çözebiliriz. Zira ben ilk paylaştığınız örnek dosyalarda sonuç alabiliyorum.

Grknpkdzn · 13 Mayıs 2021

Buyurun hocam..
Aylık dosyayı çalıştırdığınızda veriyi çektirin ve
Ayın 5 inde "I" sütununa, ayın 9 unda da "H" sütununa bakabilirsiniz.
Not: Rar dosyasının içinde göreceğiniz mesai talep formları birimlerden geliyor, devamında ben aylık dosya ile bunları konsolide ediyorum.
Yada etmeye çalışıyorum.

Korhan Ayhan · 13 Mayıs 2021

Zipleme şansınız varsa rica edebilirmiyim.

Eklediğiniz rar dosyasını net üzerinden çevirip açtığımda aşağıdaki dosyalar 0 KB boyutunda çıkıyor.

02.05.21 MESAİ LİSTESİ TALEP FORMU
04.05.21 MESAİ LİSTESİ TALEP FORMU
08.05.21 MESAİ LİSTESİ TALEP FORMU

Haluk · 13 Mayıs 2021

Korhan Bey, "zip" formatı ektedir...

.

Korhan Ayhan · 13 Mayıs 2021

Teşekkürler Haluk Bey..

Şimdi dosyalara erişebildim.

Veri aktarımında ADO kullandığımız için Evren beyin #25 nolu mesajında belirttiği sorunlar oluşmuş durumda.

Yani bir sütuna siz hem sayısal veri hem de metinsel veriler girmişsiniz. ADO sütundaki ilk 10 satırdaki veriye bakar en çok hangi veri türü varsa o sütun için o veri tipiniz baz alarak işlem yapar.

Sizin verdiğiniz tarihlerde bu sorunlar var. Bu sorun bağlantı satırında IMEX=1 kullanılarak aşılabilir. Fakat 9 Mayıs tarihli dosyanızda H18-H19 hücrelerinde saat girişinde nokta sembolü kullanılmış. Bu veriyi IMEX=1 kullansamda ADO bende aktarımı yapamadı.

Eğer dosyalarda böyle karışık ve düzensiz veri girişleri oluyorsa ADO yerine klasik olan dosyayı aç-kopyala-yapıştır-dosyayı kapat yöntemini kullanmak daha sağlıklı sonuçlar verecektir.

Grknpkdzn · 13 Mayıs 2021

Korhan bey,
İşte tamda bu noktada birimlere günlük girdi yapacağı öyle bir taslak dosyası vermeliyim ki, onun dikkatsizce girdiği veri, bizim için olması gereken standarda otomatik olarak dönüştürülüyor olsun.
Bilmiyorum çok mu fütüristtik oldu?

Grknpkdzn · 13 Mayıs 2021

Ki, bu kadarı bile benim için makbule geçmiştir.
Hele ki, gecenin bu saatinde yardımlarınız için gerçekten çok teşekkür ederim..

Kapalı dosyadan buton ile veri alma.

Grknpkdzn

Grknpkdzn

Korhan Ayhan

Administrator

Grknpkdzn

Ekli dosyalar

Orion1

Uzman

Grknpkdzn

Korhan Ayhan

Administrator

Grknpkdzn

Korhan Ayhan

Administrator

Korhan Ayhan

Administrator

Grknpkdzn

Korhan Ayhan

Administrator

Grknpkdzn

Korhan Ayhan

Administrator

Grknpkdzn

Ekli dosyalar

Korhan Ayhan

Administrator

Haluk

𐱅𐰇𐰼𐰚

Ekli dosyalar

Korhan Ayhan

Administrator

Grknpkdzn

Grknpkdzn