ADO ile Şartlı Veri Güncelleme, ilgili işlemin VBA kodları ile nasıl yapacağınızı öğreten bir Hazır Makro Kodu içermektedir.
Hazır Kod: ADO ile Şartlı Veri Güncelleme
VBA:
Sub ado_ile_sartli_veri_guncelleme()
Dim vaFiles As Variant, wbkToCopy As Workbook, ws As Worksheet, wsa As Worksheet, depo As Range
ThisWorkbook.Activate
Set ws = Sheet2
un = "Dear " & Environ("UserName")
ms1 = MsgBox("Do You Want to Import Data from Multiple Workbooks", vbInformation + vbYesNo, un)
If ms1 = vbYes Then
ChDir (ThisWorkbook.Path)
vaFiles = Application.GetOpenFilename(FileFilter:="Microsoft Excel Workbooks(*.xls;*.xlsx;*.xlsb;*.xlsm),*.xls;*.xls;*.xlsx;*.xlsb;*.xlsm", Title:="Select Files to Proceed", MultiSelect:=True)
With Application
.DisplayAlerts = False
.ScreenUpdating = False
End With
say = ws.Cells(175, 3).End(3).Row + 1
If say < 4 Then say = 4
If IsArray(vaFiles) Then
For i = LBound(vaFiles) To UBound(vaFiles)
If vaFiles(i) = ThisWorkbook.Path & Application.PathSeparator & ThisWorkbook.Name Then
ms4 = MsgBox("Cannot Open Itself", vbExclamation, un)
GoTo skipfile:
End If
Set wbkToCopy = Workbooks.Open(Filename:=vaFiles(i))
Set wsa = ActiveWorkbook.ActiveSheet
Set depo = ThisWorkbook.Worksheets(1).Columns(3).Find(wsa.Range("B2").Value, , , 1)
If Not depo Is Nothing Then
ws.Cells(depo.Row, "C") = wsa.Range("B2")
ws.Cells(depo.Row, "D") = wsa.Range("B1")
ws.Cells(depo.Row, "E") = wsa.Range("B5")
ws.Cells(depo.Row, "F") = wsa.Range("P4")
ws.Cells(depo.Row, "H") = wsa.Range("Q4")
ws.Cells(depo.Row, "J") = wsa.Range("S4")
ws.Cells(depo.Row, "L") = wsa.Range("T4")
ws.Cells(depo.Row, "O") = wsa.Range("B3")
ws.Cells(depo.Row, "R") = wsa.Range("B4")
wbkToCopy.Close savechanges:=False
Else
ws.Cells(say, "C") = wsa.Range("B2")
ws.Cells(say, "D") = wsa.Range("B1")
ws.Cells(say, "E") = wsa.Range("B5")
ws.Cells(say, "F") = wsa.Range("P4")
ws.Cells(say, "H") = wsa.Range("Q4")
ws.Cells(say, "J") = wsa.Range("S4")
ws.Cells(say, "L") = wsa.Range("T4")
ws.Cells(say, "O") = wsa.Range("B3")
ws.Cells(say, "R") = wsa.Range("B4")
wbkToCopy.Close savechanges:=False
say = say + 1
End If
skipfile:
Next i
ms5 = MsgBox("Data Import Finished", vbInformation, un)
Else
ms3 = MsgBox("No Files Selected", vbExclamation, un)
End If
Else
ms2 = MsgBox("Cancelled", vbInformation, un)
End If
With Application
.DisplayAlerts = True
.ScreenUpdating = True
End With
End Sub
Açıklama
Kodları, sayfa isimlerini vs kendi çalışmalarınıza uyarlamanız gerekebilir.İçerikte dosya yoktur, kodları kendi çalışmalarınıza uyarlayabilirsiniz.
Faydalanılması temennisiyle.
Kriter Bazlı En Küçük Sayıyı Bulma
2025-03-16
Skor Gösterge Paneli Hazırlama
2025-03-17