Soru Kapalı Dosyada Koşullu Veri Güncelleme

[murat_fidan]

Paylaşmış olduğum çalışma ile yapmak istediğim AÇIK kitabın "A" sütununa yazdığım TC kimlik numaralarını Kapalı dosyada bulup Açık kitabın ilgili sütunlarına yazdığım verileri güncellemesini istiyorum. Ancak bunu yaparken Durumu "AKTİF" olanları güncellesin istiyorum. Çünkü durumu AKTİF ve PASİF olan olan mükerrer kayıtlar bulunmaktadır. Veri sayım yaklaşık 10000 civarındadır. Yardımlarınız için şimdiden teşekkürler

 

[murat_fidan]

"Dictionary" nesnesi ile bir alternatif, denersiniz...

Private Sub CommandButton1_Click()
    Dim filePath As String, arrData(), myArr()
    Dim sourceSheet As Worksheet
   
    filePath = ThisWorkbook.Path & "\KAPALI KİTAP.xlsx"
   
    Application.ScreenUpdating = False
    
    GetObject filePath
    Windows(Dir(filePath)).Visible = False
   
    Set sourceSheet = Workbooks(Dir(filePath)).Sheets("Veri")
    lastSourceRow = sourceSheet.Range("A" & Rows.Count).End(xlUp).Row
   
    arrData = sourceSheet.Range("A2:AC" & lastSourceRow).Value
   
    Workbooks(Dir(filePath)).Close SaveChanges:=False
    
    Set dict = CreateObject("Scripting.Dictionary")
   
    For i = 1 To UBound(arrData)
        criteria = arrData(i, 2)
        If Not dict.Exists(criteria) Then
            dict(criteria) = i
        End If
    Next
    
    lastDataRow = Range("A" & Rows.Count).End(xlUp).Row
    myArr = Range("A2:A" & lastDataRow).Value
   
    ReDim arrResult(1 To UBound(myArr), 1 To 29)
   
    For i = 1 To UBound(myArr)
       iCount = iCount + 1
       criteria = myArr(i, 1)
       If dict.Exists(criteria) Then
            If arrData(dict(criteria), 23) = "AFTİF" Then
                arrResult(iCount, 1) = arrData(dict(criteria), 1)
                arrResult(iCount, 2) = arrData(dict(criteria), 10)
                arrResult(iCount, 3) = arrData(dict(criteria), 11)
                arrResult(iCount, 4) = arrData(dict(criteria), 23)
            ElseIf arrData(dict(criteria), 23) = "PASİF" Then
                arrResult(iCount, 1) = Range("B" & i + 1)
                arrResult(iCount, 2) = Range("C" & i + 1)
                arrResult(iCount, 3) = Range("D" & i + 1)
                arrResult(iCount, 4) = arrData(dict(criteria), 23)
            End If
       End If
    Next
    
    Range("B2").Resize(iCount, 4) = arrResult
   
    Application.ScreenUpdating = True
End Sub

.

Haluk bey cevap için öncelikle çok teşekkürler. Yazmış olduğunuz makroyu denedim. Ancak Kapalı dosyada ki verileri güncellemedi. Açık kitabın ilgili sütunlarına yazdığım verileri TC kimlik numarasını baz alarak Kapalı kitapta bulup kapalı kitapta güncellemesini istemiştim.

 

[Haluk]

Sonradan fark ettim, mesajımı sildim..... Ben, kapalı kitaptan açık kitaba transfer yapmıştım. Sizin istediğiniz tam tersiymiş.

.

 

[murat_fidan]

Evet haluk bey tam tersi olmuş

 

[Haluk]

Aşağıdaki kodu deneyin, bakalım oldu mu ?

Private Sub CommandButton1_Click()
'   Haluk 02/01/2022
'   E-Posta: sa4truss@gmail.com

    Dim adoCN As Object, TargetFile As String, strSQL As String, tStart As Double
     
    tStart = Timer
   
    Set adoCN = CreateObject("ADODB.Connection")
   
    TargetFile = ThisWorkbook.Path & "\KAPALI KİTAP.xlsx"
   
    adoCN.Provider = "Microsoft.ACE.OLEDB.12.0"
    adoCN.Properties("Data Source") = TargetFile
    adoCN.Properties("Extended Properties") = "Excel 12.0; HDR=Yes"
    adoCN.Open
       
    lastRow = Range("A" & Rows.Count).End(xlUp).Row
   
    For i = 2 To lastRow
        strSQL = "Update [VERİ$] Set [AYRILIŞ TARİHİ] = '" & Range("C" & i) & "', [AYRILIŞ NEDENİ] = '" & Range("D" & i) & "' Where [T#C KİMLİK NO] =" & Range("A" & i) & " And [DURUMU] ='PASİF'"
        adoCN.Execute strSQL
    Next
   
    MsgBox "Veri aktarımı tamamlanmıştır." & Chr(10) & Chr(10) & _
           "İşlem süresi ; " & Format(Timer - tStart, "0.00") & " Saniye", vbInformation
         
    adoCN.Close
    Set adoCN = Nothing
End Sub

.

 

[murat_fidan]

Aşağıdaki kodu deneyin, bakalım oldu mu ?

Private Sub CommandButton1_Click()
'   Haluk 02/01/2022
'   E-Posta: sa4truss@gmail.com

    Dim adoCN As Object, TargetFile As String, strSQL As String, tStart As Double
   
    Const adOpenStatic = 3
    Const adUseClient = 3
    Const adLockBatchOptimistic = 4
   
    tStart = Timer
   
    Set adoCN = CreateObject("ADODB.Connection")
   
    TargetFile = ThisWorkbook.Path & "\KAPALI KİTAP.xlsx"
   
    adoCN.Provider = "Microsoft.ACE.OLEDB.12.0"
    adoCN.Properties("Data Source") = TargetFile
    adoCN.Properties("Extended Properties") = "Excel 12.0; HDR=Yes"
    adoCN.Open
       
    lastRow = Range("A" & Rows.Count).End(xlUp).Row
   
    For i = 2 To lastRow
        strSQL = "Update [VERİ$] Set [AYRILIŞ TARİHİ] = '" & Range("C" & i) & "', [AYRILIŞ NEDENİ] = '" & Range("D" & i) & "' Where [T#C KİMLİK NO] =" & Range("A" & i) & " And [DURUMU] ='PASİF'"
        adoCN.Execute strSQL
    Next
   
    MsgBox "Veri aktarımı tamamlanmıştır." & Chr(10) & Chr(10) & _
           "İşlem süresi ; " & Format(Timer - tStart, "0.00") & " Saniye", vbInformation
         
    adoCN.Close
    Set adoCN = Nothing
End Sub

.

Teşekkürler Haluk bey istediğim gibi oldu hakkınızı helal edin