ADO ile Şartlı Veri Güncelleme

ADO ile Şartlı Veri Güncelleme

Kısa Açıklama

ADO ile Şartlı Veri Güncelleme başlıklı bu içerikte, ilgili işlemlere yönelik olarak hazırlanan öğretici bir dosya yer almaktadır.
ADO ile Şartlı Veri Güncelleme


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.
Benzer Dosyalar Popüler İçerikler Daha Fazlası
Geri
Üst