Kapalı Dosyalardan Veri Aktarımı

Korhan Ayhan · 1 Kasım 2021

Deneyiniz.

C++:

Option Explicit

Sub Import_Data()
    Dim K1 As Workbook, S1 As Worksheet, S2 As Worksheet, K2 As Workbook, S3 As Worksheet
    Dim File_Path As String, My_File As String, XL_App As Object, My_Date As String
    Dim Find_Store As Range, Store_Name As String, Process_Time As Double
   
    Process_Time = Timer
   
    Set K1 = ThisWorkbook
    Set XL_App = VBA.CreateObject("Excel.Application")
    XL_App.Visible = False
   
    File_Path = K1.Path & "\"
   
    My_File = Dir(File_Path & "*.xls*")
   
    While My_File <> ""
        If My_File <> K1.name Then
            Set K2 = XL_App.Workbooks.Open(File_Path & My_File)
            Set S3 = K2.Sheets(1)
            My_Date = Format(S3.Range("A8").Value, "dd.mm.yyyy")
            Set S1 = K1.Sheets(CStr(My_Date))
            Set S2 = K1.Sheets(CStr(My_Date) & " Gider")
            Store_Name = VBA.Split(My_File, " ")(0)
            Set Find_Store = S1.Range("A:A").Find(Store_Name, , , xlWhole)
            If Not Find_Store Is Nothing Then
                S1.Cells(Find_Store.Row, 2).Value = IIf(S3.Range("D8").Value = Empty, 0, S3.Range("D8").Value)
                S1.Cells(Find_Store.Row, 3).Value = IIf(S3.Range("D9").Value = Empty, 0, S3.Range("D9").Value)
                S1.Cells(Find_Store.Row, 4).Value = IIf(S3.Range("D10").Value = Empty, 0, S3.Range("D10").Value)
                S1.Cells(Find_Store.Row, 5).Value = IIf(S3.Range("D11").Value = Empty, 0, S3.Range("D11").Value)
                S1.Cells(Find_Store.Row, 6).Value = IIf(S3.Range("D12").Value = Empty, 0, S3.Range("D12").Value)
                S1.Cells(Find_Store.Row, 8).Value = WorksheetFunction.Sum(S3.Range("K9:K12"))
                S1.Cells(Find_Store.Row, 9).Value = WorksheetFunction.Sum(S3.Range("K13:K15"))
                S1.Cells(Find_Store.Row, 10).Value = IIf(S3.Range("K8").Value = Empty, 0, S3.Range("K8").Value)
            End If
           
            Set Find_Store = S2.Range("A:A").Find(Store_Name, , , xlWhole)
            If Not Find_Store Is Nothing Then
                S2.Cells(Find_Store.Row, 2).Value = S3.Range("F9").Value
                S2.Cells(Find_Store.Row, 3).Value = IIf(S3.Range("K9").Value = Empty, 0, S3.Range("K9").Value)
                S2.Cells(Find_Store.Row, 4).Value = S3.Range("F10").Value
                S2.Cells(Find_Store.Row, 5).Value = IIf(S3.Range("K10").Value = Empty, 0, S3.Range("K10").Value)
                S2.Cells(Find_Store.Row, 6).Value = S3.Range("F11").Value
                S2.Cells(Find_Store.Row, 7).Value = IIf(S3.Range("K11").Value = Empty, 0, S3.Range("K11").Value)
                S2.Cells(Find_Store.Row, 8).Value = S3.Range("F12").Value
                S2.Cells(Find_Store.Row, 9).Value = IIf(S3.Range("K12").Value = Empty, 0, S3.Range("K12").Value)
                S2.Cells(Find_Store.Row, 10).Value = S3.Range("F13").Value
                S2.Cells(Find_Store.Row, 11).Value = IIf(S3.Range("K13").Value = Empty, 0, S3.Range("K13").Value)
                S2.Cells(Find_Store.Row, 12).Value = S3.Range("F14").Value
                S2.Cells(Find_Store.Row, 13).Value = IIf(S3.Range("K14").Value = Empty, 0, S3.Range("K14").Value)
                S2.Cells(Find_Store.Row, 14).Value = S3.Range("F15").Value
                S2.Cells(Find_Store.Row, 15).Value = IIf(S3.Range("K15").Value = Empty, 0, S3.Range("K15").Value)
            End If
           
            K2.Close 0
        End If
        My_File = Dir
    Wend
   
    XL_App.Quit
   
    Set XL_App = Nothing
    Set K1 = Nothing
    Set S1 = Nothing
    Set S2 = Nothing
    Set K2 = Nothing
    Set S3 = Nothing
   
    MsgBox "Depo verileri güncellenmiştir." & vbCr & vbCr & _
           "İşlem süresi ; " & Format(Timer - Process_Time, "0.00") & " Saniye", vbInformation
End Sub

mukoli · 1 Kasım 2021

Merhaba hocam olmuştur çok teşekkür ederim ilginize alakanıza iyi akşamlar dilerim

Korhan Ayhan · 2 Kasım 2021

Bu da son paylaştığınız dosyalara için ADO ile alternatif;

C++:

Option Explicit

Sub Import_Data_Ado()
    Dim Process_Time As Double, File_Folder As String, My_File As String
    Dim My_Connection As Object, My_Recordset As Object, My_Query As String
    Dim S1 As Worksheet, S2 As Worksheet, Store_Name As String
    Dim Old_Calculation_Mode As Integer, Find_Store As Range
    
    Process_Time = Timer
    
    With Application
        .ScreenUpdating = 0
         Old_Calculation_Mode = .Calculation
        .Calculation = -4135
    End With
    
    Set My_Connection = VBA.CreateObject("AdoDb.Connection")
    Set My_Recordset = VBA.CreateObject("AdoDb.Recordset")
              
    File_Folder = ThisWorkbook.Path & "\"
    
    My_File = Dir(File_Folder & "*.xls*")
    
    While My_File <> ""
        If My_File <> ThisWorkbook.Name Then
            My_Connection.Open "Provider=Microsoft.Ace.OleDb.12.0;Data Source=" & _
            File_Folder & My_File & ";Extended Properties=""Excel 12.0;Hdr=No"""
        
            My_Query = "Select F1 From [Sayfa1$A8:A8]"
            My_Recordset.Open My_Query, My_Connection, 1, 1
            
            If My_Recordset.RecordCount > 0 Then
                Set S1 = ThisWorkbook.Sheets(CStr(Format(My_Recordset.Fields(0).Value, "dd.mm.yyyy")))
                Set S2 = ThisWorkbook.Sheets(CStr(Format(My_Recordset.Fields(0).Value, "dd.mm.yyyy")) & " Gider")
                
                Store_Name = VBA.Split(My_File, " ")(0)
                Set Find_Store = S1.Range("A:A").Find(Store_Name, , , xlWhole)
                
                If Not Find_Store Is Nothing Then
                    S1.Cells(Find_Store.Row, 2).Value = My_Connection.Execute("Select * From [Sayfa1$D8:D8]").Fields(0).Value
                    S1.Cells(Find_Store.Row, 3).Value = My_Connection.Execute("Select * From [Sayfa1$D9:D9]").Fields(0).Value
                    S1.Cells(Find_Store.Row, 4).Value = My_Connection.Execute("Select * From [Sayfa1$D10:D10]").Fields(0).Value
                    S1.Cells(Find_Store.Row, 5).Value = My_Connection.Execute("Select * From [Sayfa1$D11:D11]").Fields(0).Value
                    S1.Cells(Find_Store.Row, 6).Value = My_Connection.Execute("Select * From [Sayfa1$D12:D12]").Fields(0).Value
                    S1.Cells(Find_Store.Row, 8).Value = My_Connection.Execute("Select Sum(F1) From [Sayfa1$K9:K12]").Fields(0).Value
                    S1.Cells(Find_Store.Row, 9).Value = My_Connection.Execute("Select Sum(F1) From [Sayfa1$K13:K15]").Fields(0).Value
                    S1.Cells(Find_Store.Row, 10).Value = My_Connection.Execute("Select * From [Sayfa1$K8:K8]").Fields(0).Value
                End If
            
                Set Find_Store = S2.Range("A:A").Find(Store_Name, , , xlWhole)
                If Not Find_Store Is Nothing Then
                    S2.Cells(Find_Store.Row, 2).Value = My_Connection.Execute("Select * From [Sayfa1$F9:F9]").Fields(0).Value
                    S2.Cells(Find_Store.Row, 3).Value = My_Connection.Execute("Select * From [Sayfa1$K9:K9]").Fields(0).Value
                    S2.Cells(Find_Store.Row, 4).Value = My_Connection.Execute("Select * From [Sayfa1$F10:F10]").Fields(0).Value
                    S2.Cells(Find_Store.Row, 5).Value = My_Connection.Execute("Select * From [Sayfa1$K10:K10]").Fields(0).Value
                    S2.Cells(Find_Store.Row, 6).Value = My_Connection.Execute("Select * From [Sayfa1$F11:F11]").Fields(0).Value
                    S2.Cells(Find_Store.Row, 7).Value = My_Connection.Execute("Select * From [Sayfa1$K11:K11]").Fields(0).Value
                    S2.Cells(Find_Store.Row, 8).Value = My_Connection.Execute("Select * From [Sayfa1$F12:F12]").Fields(0).Value
                    S2.Cells(Find_Store.Row, 9).Value = My_Connection.Execute("Select * From [Sayfa1$K12:K12]").Fields(0).Value
                    S2.Cells(Find_Store.Row, 10).Value = My_Connection.Execute("Select * From [Sayfa1$F13:F13]").Fields(0).Value
                    S2.Cells(Find_Store.Row, 11).Value = My_Connection.Execute("Select * From [Sayfa1$K13:K13]").Fields(0).Value
                    S2.Cells(Find_Store.Row, 12).Value = My_Connection.Execute("Select * From [Sayfa1$F14:F14]").Fields(0).Value
                    S2.Cells(Find_Store.Row, 13).Value = My_Connection.Execute("Select * From [Sayfa1$K14:K14]").Fields(0).Value
                    S2.Cells(Find_Store.Row, 14).Value = My_Connection.Execute("Select * From [Sayfa1$F15:F15]").Fields(0).Value
                    S2.Cells(Find_Store.Row, 15).Value = My_Connection.Execute("Select * From [Sayfa1$K15:K15]").Fields(0).Value
                End If
            End If
            
            If My_Connection.State <> 0 Then My_Connection.Close
            If My_Recordset.State <> 0 Then My_Recordset.Close
        End If
        My_File = Dir
    Wend
    
    Set My_Recordset = Nothing
    Set My_Connection = Nothing
    Set S1 = Nothing
    Set S2 = Nothing
    
    With Application
        .ScreenUpdating = 1
        .Calculation = Old_Calculation_Mode
    End With
    
    MsgBox "Your transaction is complete." & vbCr & vbCr & _
           "Processing time ; " & Format(Timer - Process_Time, "0.00") & " Second", vbInformation
End Sub

Korhan Ayhan · 2 Kasım 2021

Bu da INDEX ile alternatif;

C++:

Option Explicit

Sub Import_Data_Index()
    Dim Process_Time As Double, File_Folder As String, My_File As String
    Dim S1 As Worksheet, S2 As Worksheet, Store_Name As String
    Dim Old_Calculation_Mode As Integer, Find_Store As Range
    
    Process_Time = Timer
    
    With Application
        .ScreenUpdating = 0
         Old_Calculation_Mode = .Calculation
        .Calculation = -4135
    End With
    
    File_Folder = ThisWorkbook.Path & "\"
    
    My_File = Dir(File_Folder & "*.xls*")
    
    While My_File <> ""
        If My_File <> ThisWorkbook.Name Then
            Range("Z1").Formula = "=INDEX('" & File_Folder & "[" & My_File & "]Sayfa1" & "'!A:A,8)"
            Set S1 = ThisWorkbook.Sheets(CStr(Format(Range("Z1"), "dd.mm.yyyy")))
            Set S2 = ThisWorkbook.Sheets(CStr(Format(Range("Z1"), "dd.mm.yyyy")) & " Gider")
            Range("Z1").Clear

            Store_Name = VBA.Split(My_File, " ")(0)
            Set Find_Store = S1.Range("A:A").Find(Store_Name, , , xlWhole)

            If Not Find_Store Is Nothing Then
                S1.Cells(Find_Store.Row, 2).Formula = "=INDEX('" & File_Folder & "[" & My_File & "]Sayfa1" & "'!D1:D15,8)"
                S1.Cells(Find_Store.Row, 3).Formula = "=INDEX('" & File_Folder & "[" & My_File & "]Sayfa1" & "'!D1:D15,9)"
                S1.Cells(Find_Store.Row, 4).Formula = "=INDEX('" & File_Folder & "[" & My_File & "]Sayfa1" & "'!D1:D15,10)"
                S1.Cells(Find_Store.Row, 5).Formula = "=INDEX('" & File_Folder & "[" & My_File & "]Sayfa1" & "'!D1:D15,11)"
                S1.Cells(Find_Store.Row, 6).Formula = "=INDEX('" & File_Folder & "[" & My_File & "]Sayfa1" & "'!D1:D15,12)"
                S1.Cells(Find_Store.Row, 8).Formula = "=SUM('" & File_Folder & "[" & My_File & "]Sayfa1'!K9:K12)"
                S1.Cells(Find_Store.Row, 9).Formula = "=SUM('" & File_Folder & "[" & My_File & "]Sayfa1'!K13:K15)"
                S1.Cells(Find_Store.Row, 10).Formula = "=INDEX('" & File_Folder & "[" & My_File & "]Sayfa1" & "'!K1:K15,8)"
            End If

            S1.Range("B2:F28").Value = S1.Range("B2:F28").Value
            S1.Range("H2:J28").Value = S1.Range("H2:J28").Value

            Set Find_Store = S2.Range("A:A").Find(Store_Name, , , xlWhole)
            If Not Find_Store Is Nothing Then
                S2.Cells(Find_Store.Row, 2).Value = "=INDEX('" & File_Folder & "[" & My_File & "]Sayfa1" & "'!F1:F15,9)"
                S2.Cells(Find_Store.Row, 3).Value = "=INDEX('" & File_Folder & "[" & My_File & "]Sayfa1" & "'!K1:K15,9)"
                S2.Cells(Find_Store.Row, 4).Value = "=INDEX('" & File_Folder & "[" & My_File & "]Sayfa1" & "'!F1:F15,10)"
                S2.Cells(Find_Store.Row, 5).Value = "=INDEX('" & File_Folder & "[" & My_File & "]Sayfa1" & "'!K1:K15,10)"
                S2.Cells(Find_Store.Row, 6).Value = "=INDEX('" & File_Folder & "[" & My_File & "]Sayfa1" & "'!F1:F15,11)"
                S2.Cells(Find_Store.Row, 7).Value = "=INDEX('" & File_Folder & "[" & My_File & "]Sayfa1" & "'!K1:K15,11)"
                S2.Cells(Find_Store.Row, 8).Value = "=INDEX('" & File_Folder & "[" & My_File & "]Sayfa1" & "'!F1:F15,12)"
                S2.Cells(Find_Store.Row, 9).Value = "=INDEX('" & File_Folder & "[" & My_File & "]Sayfa1" & "'!K1:K15,12)"
                S2.Cells(Find_Store.Row, 10).Value = "=INDEX('" & File_Folder & "[" & My_File & "]Sayfa1" & "'!F1:F15,13)"
                S2.Cells(Find_Store.Row, 11).Value = "=INDEX('" & File_Folder & "[" & My_File & "]Sayfa1" & "'!K1:K15,13)"
                S2.Cells(Find_Store.Row, 12).Value = "=INDEX('" & File_Folder & "[" & My_File & "]Sayfa1" & "'!F1:F15,14)"
                S2.Cells(Find_Store.Row, 13).Value = "=INDEX('" & File_Folder & "[" & My_File & "]Sayfa1" & "'!K1:K15,14)"
                S2.Cells(Find_Store.Row, 14).Value = "=INDEX('" & File_Folder & "[" & My_File & "]Sayfa1" & "'!F1:F15,15)"
                S2.Cells(Find_Store.Row, 15).Value = "=INDEX('" & File_Folder & "[" & My_File & "]Sayfa1" & "'!K1:K15,15)"
            End If
            
            S2.Range("B2:O28").Value = S2.Range("B2:O28").Value
        End If
        
        My_File = Dir
    Wend
    
    With Application
        .ScreenUpdating = 1
        .Calculation = Old_Calculation_Mode
    End With
    
    MsgBox "Your transaction is complete." & vbCr & vbCr & _
           "Processing time ; " & Format(Timer - Process_Time, "0.00") & " Second", vbInformation
End Sub

mukoli · 2 Kasım 2021

Merhaba korhan hocam valla süpersiniz hepsini denicem birazdan hangisi iyiyse onu kullanıcam çok teşekkür ederim

mukoli · 2 Kasım 2021

Hocam index ve ado ile yapılan cok hızlı index karışık gibi kodlar ama ado gayet anlaşılır düzeyde oyuzden ado kullanıcam . İlk yaptgınız kod yavaş çalışıyor nedenini ögrenebilirmiyim bu işlemlerde ado kullanmak daha iyimidir

Korhan Ayhan · 2 Kasım 2021

İlk yöntemde dosya açıldığı için küçük bir zaman kaybı yaşanıyor.

INDEX ve ADO yöntemlerinden dosya açılmadan işlem yapılıyor. Bu sebeple daha hızlı sonuç vermektedir.

mukoli · 2 Kasım 2021

Teşekkürler hocam gününüz güzel geçsin

Kapalı Dosyalardan Veri Aktarımı

Korhan Ayhan

Administrator

mukoli

Korhan Ayhan

Administrator

Korhan Ayhan

Administrator

mukoli

mukoli

Korhan Ayhan

Administrator

mukoli