SQL diğer tabloda kontrol (kod hızlandırma)

[tamer42]

Merhabalar,

Ekli dosyada aşağıdaki kod ile bir sayfada olan verileri diğer sayfada olup olmadığını kontrol etmeye çalışıyorum. Bir nevi COUNTIF fonksiyonu

bu işlemi for ..... next döngüsüne girmeden daha hızlı bir şekilde yapmanın bir yolu olabilir mi?

Teşekkürler,
iyi Haftasonları...

Sub xCountIF()
Dim RS As Object
Dim SH As Worksheet
Dim myPath  As String
Dim i As Long
Dim LastRow As Long
Dim deg As Variant
Dim zaman As Double

zaman = Timer


Set Con = VBA.CreateObject("adodb.Connection")
Set RS = VBA.CreateObject("adodb.Recordset")


Set SH = ActiveWorkbook.Sheets("Hedef")
SH.Range("D:Z").ClearContents
LastRow = SH.Cells(SH.Rows.Count, "A").End(xlUp).Row

myPath = ActiveWorkbook.Path
    WB1 = ActiveWorkbook.FullName
            
    strConnection = _
        "Provider=Microsoft.ACE.OLEDB.12.0;" & _
        "User ID=Admin;" & _
        "Data Source='" & WB1 & "';" & _
        "Extended Properties=""Excel 12.0;IMEX=1;Hdr=Yes"""
        
        Con.Open strConnection
        
  For i = 2 To LastRow
    deg = SH.Cells(i, 1)

    sorgu = "Select * From [Data$] WHERE [KODU]='" & deg & "'"
    
    RS.Open sorgu, Con

    If Not RS.EOF Then
        SH.Cells(i, 4) = 1
    Else
        SH.Cells(i, 4) = 0
    End If

RS.Close

Next i

Set RS = Nothing

Set Con = Nothing

MsgBox "Süre: " & zaman

End Sub

 

[Ziynettin]

Merhaba,

Alternatif kod. B, C, D verileriniz de kod ile yazdırılıyor.

Sub test()
Dim s1 As Worksheet, s2 As Worksheet, a(), b()
Dim dc As Object, dv As Object, krt As String
Dim son As Long, i As Long, say As Long

Set s1 = Sheets("Hedef")
Set s2 = Sheets("Data")
son = s2.Range("A" & Rows.Count).End(xlUp).Row
If son > 2 Then
    a = s2.Range("A1:B" & son).Value
    Set dc = CreateObject("scripting.dictionary")
    Set dv = CreateObject("scripting.dictionary")
    For i = 2 To UBound(a)
        If a(i, 1) <> "" Then
            dc(a(i, 1)) = dc(a(i, 1)) + 1
            dv(a(i, 1)) = a(i, 2)
        End If
    Next i
    
    son = 0
    son = s1.Range("A" & Rows.Count).End(xlUp).Row
    If son > 2 Then
        a = s1.Range("A1:A" & son).Value
        ReDim b(1 To UBound(a), 1 To 3)
            For i = 2 To UBound(a)
                say = say + 1
                krt = a(i, 1)
                If dc.exists(krt) Then
                    b(say, 1) = dc(krt)
                    b(say, 2) = dv(krt)
                    b(say, 3) = 1
                Else
                    b(say, 1) = 0
                    b(say, 3) = 0
                End If
            Next i
        s1.[B2].Resize(say, 3) = b
    End If
End If
MsgBox "İşlem tamam.", vbInformation
End Sub

 

[veyselemre]

Hedef sayfası D1'e BAK yazın;

Sub test()

    Sheets("Hedef").Range("C2:D" & Sheets("Hedef").Cells(Rows.Count, 1).End(xlUp).Row).ClearContents
    
    With CreateObject("ADODB.CONNECTION")
        .Open "Provider=Microsoft.Ace.Oledb.12.0;Extended Properties='Excel 12.0;HDR=YES;IMEX=0';Data Source=" & _
               ThisWorkbook.FullName
        .Execute " UPDATE [HEDEF$A1:D" & Sheets("HEDEF").Cells(Rows.Count, 1).End(xlUp).Row & _
                 "] AS R INNER JOIN [Data$A1:B" & Sheets("Data").Cells(Rows.Count, 1).End(xlUp).Row & _
                 "] AS D ON (D.KODU = R.KODU) SET R.DÜŞEYARA =D.MS1, R.BAK= IIF(D.MS1 IS NULL,0,1)"
        .Close
    End With

End Sub

 

[tamer42]

Hedef sayfası D1'e BAK yazın;

Sub test()

    Sheets("Hedef").Range("C2:D" & Sheets("Hedef").Cells(Rows.Count, 1).End(xlUp).Row).ClearContents
  
    With CreateObject("ADODB.CONNECTION")
        .Open "Provider=Microsoft.Ace.Oledb.12.0;Extended Properties='Excel 12.0;HDR=YES;IMEX=0';Data Source=" & _
               ThisWorkbook.FullName
        .Execute " UPDATE [HEDEF$A1:D" & Sheets("HEDEF").Cells(Rows.Count, 1).End(xlUp).Row & _
                 "] AS R INNER JOIN [Data$A1:B" & Sheets("Data").Cells(Rows.Count, 1).End(xlUp).Row & _
                 "] AS D ON (D.KODU = R.KODU) SET R.DÜŞEYARA =D.MS1, R.BAK= IIF(D.MS1 IS NULL,0,1)"
        .Close
    End With

End Sub

Veysel Hocam çok teşekkür ederim, emeğinize sağlık;