Kapalı Dosyadan Veri Çekme

TheNomAd · 27 Haziran 2020

Korhan Ayhan' Alıntı:
Deneyin bakalım olmuş mu?

Yapı itibari ile olmuş elinize sağlık. Tek kusuru Aylık ebat dönüşü sheetinde bakiye tonaj sütununa boyları toplayıp getiriyor. Bakiye tonajı toplayıp getirmesi için küçük bir dokunuşunuza ihtiyaç var sanırım.

Korhan Ayhan · 27 Haziran 2020

#40 nolu mesajımda ki dosyayı revize ettim. Tekrar deneyiniz.

TheNomAd · 27 Haziran 2020

Korhan Ayhan' Alıntı:
Deneyin bakalım olmuş mu?

Olmuş elinize emeğinize sağlık...

TheNomAd · 27 Haziran 2020

Son bir şey rica edebilir miyim acaba? Ben eklemeye çalıştım ama doğru toplatamadım. Aylık Ebat Dönüş sheetinde Bakiye metrajı da toplatabilir miyiz?

Korhan Ayhan · 27 Haziran 2020

Deneyiniz.

C++:

Option Explicit

Sub Verileri_Aktar()
    Dim Dosya As Variant, Zaman As Double, Baglanti As Object, S1 As Worksheet
    Dim Tum_Tablolar As Object, Sayfa As Object, Dizi As Object, S2 As Worksheet
    Dim Sayfa_Adi As String, Sorgu As String, Kayit_Seti As Object
    Dim Son As Long, Veri As Variant, X As Long, Aranan As String, Say As Long
 
    Dosya = Application.GetOpenFilename(FileFilter:="Excel Çalışma Kitapları (*.xl*),*.xl*", _
            Title:="Lütfen Dosya Seçiniz", MultiSelect:=False)

    Zaman = Timer
 
    If Dosya <> False Then
        Set Baglanti = CreateObject("AdoDb.Connection")
        Set Tum_Tablolar = CreateObject("AdoX.Catalog")
        Set Sayfa = CreateObject("AdoX.Table")
        Set Dizi = CreateObject("Scripting.Dictionary")
        Set S1 = Sheets("Düzenlenmiş Data")
        Set S2 = Sheets("Aylık Ebat Dönüş")
     
        S1.Range("A2:L" & S1.Rows.Count).Clear
        S2.Range("A2:F" & S1.Rows.Count).Clear
 
        If Dosya <> ThisWorkbook.FullName Then
            Baglanti.Open "Provider=Microsoft.Ace.OleDb.12.0;Data Source=" & _
            Dosya & ";Extended Properties=""Excel 12.0;Hdr=No"""
         
            Tum_Tablolar.ActiveConnection = Baglanti
        
            For Each Sayfa In Tum_Tablolar.Tables
                If Replace(Sayfa.Name, "'", "") Like "*$" And InStr(1, Sayfa.Name, "Print_Area") = 0 Then
                    Sayfa_Adi = Sayfa.Name
                    Exit For
                End If
            Next
         
            Sorgu = "Select F29,F4,F7,F8,F1,F2,F9,F14,F15,F10,F22,F23 From [" & Sayfa_Adi & "A2:CA] Order By F29 Asc"
            Set Kayit_Seti = Baglanti.Execute(Sorgu)
            S1.Cells(S1.Rows.Count, 1).End(3)(2, 1).CopyFromRecordset Kayit_Seti
            S1.Range("A2:B" & S1.Rows.Count).NumberFormat = "dd.mm.yyyy"
            S1.Columns.AutoFit
         
            If Kayit_Seti.State <> 0 Then Kayit_Seti.Close
            If Baglanti.State <> 0 Then Baglanti.Close
        End If
 
        Son = S1.Cells(S1.Rows.Count, 1).End(3).Row
     
        If Son = 1 Then
            MsgBox "Veri bulunamadı!", vbCritical
            GoTo 10
        ElseIf Son >= 2 Then
            If Son = 2 Then Son = 3
            Veri = S1.Range("A2:L" & Son).Value
         
            ReDim Liste(1 To UBound(Veri), 1 To 6)
         
            For X = LBound(Veri) To UBound(Veri)
                Aranan = Year(Veri(X, 1)) & "|" & Month(Veri(X, 1)) & "|" & Veri(X, 3)
                If Not Dizi.Exists(Aranan) Then
                    Say = Say + 1
                    Dizi.Add Aranan, Say
                    Liste(Say, 1) = Format(Veri(X, 1), "yyyy" & "mmmm") & Veri(X, 5)
                    Liste(Say, 2) = Veri(X, 5)
                    Liste(Say, 3) = Veri(X, 3)
                    Liste(Say, 4) = 1
                    Liste(Say, 5) = Veri(X, 11)
                    Liste(Say, 6) = Veri(X, 12)
                Else
                    Liste(Dizi.Item(Aranan), 4) = Liste(Dizi.Item(Aranan), 4) + 1
                    Liste(Dizi.Item(Aranan), 5) = Liste(Dizi.Item(Aranan), 5) + Veri(X, 11)
                    Liste(Dizi.Item(Aranan), 6) = Liste(Dizi.Item(Aranan), 6) + Veri(X, 12)
                End If
            Next
     
            If Say > 0 Then
                S2.Range("A2").Resize(Say, UBound(Liste, 2)) = Liste
                S2.Range("A2:F" & S2.Rows.Count).Sort Key1:=S2.Range("A2"), Order1:=xlAscending
                S2.Range("A2:F" & S2.Rows.Count).Sort Key1:=S2.Range("B2"), Order1:=xlAscending
                S2.Range("A2:F" & S2.Rows.Count).NumberFormat = "General"
                S2.Columns.AutoFit
                S2.Select
            End If
         
            MsgBox "Veri aktarımı tamamlanmıştır." & Chr(10) & Chr(10) & _
                   "İşlem süresi ; " & Format(Timer - Zaman, "0.00") & " Saniye", vbInformation
        End If
 
10
        Set Kayit_Seti = Nothing
        Set Baglanti = Nothing
        Set Tum_Tablolar = Nothing
        Set Sayfa = Nothing
        Set Dizi = Nothing
        Set S1 = Nothing
        Set S2 = Nothing
    Else
        MsgBox "Dosya seçimi yapmadığınız için işleminiz iptal edilmiştir.", vbCritical
    End If
End Sub

TheNomAd · 28 Haziran 2020

Korhan Ayhan' Alıntı:

Deneyiniz.

C++:

Option Explicit

Sub Verileri_Aktar()
    Dim Dosya As Variant, Zaman As Double, Baglanti As Object, S1 As Worksheet
    Dim Tum_Tablolar As Object, Sayfa As Object, Dizi As Object, S2 As Worksheet
    Dim Sayfa_Adi As String, Sorgu As String, Kayit_Seti As Object
    Dim Son As Long, Veri As Variant, X As Long, Aranan As String, Say As Long

    Dosya = Application.GetOpenFilename(FileFilter:="Excel Çalışma Kitapları (*.xl*),*.xl*", _
            Title:="Lütfen Dosya Seçiniz", MultiSelect:=False)

    Zaman = Timer

    If Dosya <> False Then
        Set Baglanti = CreateObject("AdoDb.Connection")
        Set Tum_Tablolar = CreateObject("AdoX.Catalog")
        Set Sayfa = CreateObject("AdoX.Table")
        Set Dizi = CreateObject("Scripting.Dictionary")
        Set S1 = Sheets("Düzenlenmiş Data")
        Set S2 = Sheets("Aylık Ebat Dönüş")
    
        S1.Range("A2:L" & S1.Rows.Count).Clear
        S2.Range("A2:F" & S1.Rows.Count).Clear

        If Dosya <> ThisWorkbook.FullName Then
            Baglanti.Open "Provider=Microsoft.Ace.OleDb.12.0;Data Source=" & _
            Dosya & ";Extended Properties=""Excel 12.0;Hdr=No"""
        
            Tum_Tablolar.ActiveConnection = Baglanti
       
            For Each Sayfa In Tum_Tablolar.Tables
                If Replace(Sayfa.Name, "'", "") Like "*$" And InStr(1, Sayfa.Name, "Print_Area") = 0 Then
                    Sayfa_Adi = Sayfa.Name
                    Exit For
                End If
            Next
        
            Sorgu = "Select F29,F4,F7,F8,F1,F2,F9,F14,F15,F10,F22,F23 From [" & Sayfa_Adi & "A2:CA] Order By F29 Asc"
            Set Kayit_Seti = Baglanti.Execute(Sorgu)
            S1.Cells(S1.Rows.Count, 1).End(3)(2, 1).CopyFromRecordset Kayit_Seti
            S1.Range("A2:B" & S1.Rows.Count).NumberFormat = "dd.mm.yyyy"
            S1.Columns.AutoFit
        
            If Kayit_Seti.State <> 0 Then Kayit_Seti.Close
            If Baglanti.State <> 0 Then Baglanti.Close
        End If

        Son = S1.Cells(S1.Rows.Count, 1).End(3).Row
    
        If Son = 1 Then
            MsgBox "Veri bulunamadı!", vbCritical
            GoTo 10
        ElseIf Son >= 2 Then
            If Son = 2 Then Son = 3
            Veri = S1.Range("A2:L" & Son).Value
        
            ReDim Liste(1 To UBound(Veri), 1 To 6)
        
            For X = LBound(Veri) To UBound(Veri)
                Aranan = Year(Veri(X, 1)) & "|" & Month(Veri(X, 1)) & "|" & Veri(X, 3)
                If Not Dizi.Exists(Aranan) Then
                    Say = Say + 1
                    Dizi.Add Aranan, Say
                    Liste(Say, 1) = Format(Veri(X, 1), "yyyy" & "mmmm") & Veri(X, 5)
                    Liste(Say, 2) = Veri(X, 5)
                    Liste(Say, 3) = Veri(X, 3)
                    Liste(Say, 4) = 1
                    Liste(Say, 5) = Veri(X, 11)
                    Liste(Say, 6) = Veri(X, 12)
                Else
                    Liste(Dizi.Item(Aranan), 4) = Liste(Dizi.Item(Aranan), 4) + 1
                    Liste(Dizi.Item(Aranan), 5) = Liste(Dizi.Item(Aranan), 5) + Veri(X, 11)
                    Liste(Dizi.Item(Aranan), 6) = Liste(Dizi.Item(Aranan), 6) + Veri(X, 12)
                End If
            Next
    
            If Say > 0 Then
                S2.Range("A2").Resize(Say, UBound(Liste, 2)) = Liste
                S2.Range("A2:F" & S2.Rows.Count).Sort Key1:=S2.Range("A2"), Order1:=xlAscending
                S2.Range("A2:F" & S2.Rows.Count).Sort Key1:=S2.Range("B2"), Order1:=xlAscending
                S2.Range("A2:F" & S2.Rows.Count).NumberFormat = "General"
                S2.Columns.AutoFit
                S2.Select
            End If
        
            MsgBox "Veri aktarımı tamamlanmıştır." & Chr(10) & Chr(10) & _
                   "İşlem süresi ; " & Format(Timer - Zaman, "0.00") & " Saniye", vbInformation
        End If

10
        Set Kayit_Seti = Nothing
        Set Baglanti = Nothing
        Set Tum_Tablolar = Nothing
        Set Sayfa = Nothing
        Set Dizi = Nothing
        Set S1 = Nothing
        Set S2 = Nothing
    Else
        MsgBox "Dosya seçimi yapmadığınız için işleminiz iptal edilmiştir.", vbCritical
    End If
End Sub

Elinize sağlık...

Kapalı Dosyadan Veri Çekme

TheNomAd

Korhan Ayhan

Administrator

TheNomAd

TheNomAd

Ekli dosyalar

Korhan Ayhan

Administrator

TheNomAd