Kod:
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, My_Check As Boolean
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
On Error Resume Next
Set S1 = Nothing
Set S2 = Nothing
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")
On Error GoTo 0
If Not S1 Is Nothing And Not S2 Is Nothing Then
If ThisWorkbook.ActiveSheet.Name <> S1.Name Or ThisWorkbook.ActiveSheet.Name <> S2.Name Then
My_Check = True
GoTo 10
Exit Sub
End If
Else
My_Check = True
GoTo 10
End If
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
10 If My_Connection.State <> 0 Then My_Connection.Close
If My_Recordset.State <> 0 Then My_Recordset.Close
Set My_Recordset = Nothing
Set My_Connection = Nothing
Set S1 = Nothing
Set S2 = Nothing
With Application
.ScreenUpdating = 1
.Calculation = Old_Calculation_Mode
End With
If My_Check = False Then
MsgBox "Your transaction is complete." & vbCr & vbCr & _
"Processing time ; " & Format(Timer - Process_Time, "0.00") & " Second", vbInformation
Else
MsgBox "The transaction was terminated because the dates did not match.", vbCritical
End If
End SubMerhaba bu makro işlemi yapıldıktan sonra klasör altındaki excel dosyalarının silinmesini nasıl sağlayabiliriz. İşlem bittikten sonra sadece ana dosya kalıcak teşekkürler şimdiden iyi pazarlar herkese
