• DİKKAT

    DOSYA İndirmek/Yüklemek için ÜCRETLİ ALTIN ÜYELİK Gereklidir!
    Altın Üyelik Hakkında Bilgi

2 Çalışma Sayfasındaki Farkları Başka Sayfaya Aktarma Revize

M

mukoli

Katılım
4 Eylül 2020
Mesajlar
394
Excel Vers. ve Dili
Excel 2016
Ömer Bey Merhaba,
Bu Kodda Revize Yapabilirmiyiz Size Zahmet Uğraştım Ama Beceremedim .
Kodlar İstediğim Gibi Çalışıyor Fakat Sayfa1de Kopyalama yaparken D Sütünundaki Tarih Alanınıda Sayfa3 Kopyalamasını İstiyorum Ama Fark Olarak Algılanmasın Sadece Yanına Gelmesini istiyorum.
Bu Kod Çok Hızlı Çalışıyor 1 Saniye Gibi
Kod: 
Sub ertert()
'Dim tm!: tm = Timer
Dim x, y(), i&, j&, k&, t$
x = Sheets("Sheet2").Range("A1:C" & Sheets("Sheet2").Range("A" & Rows.Count).End(3).Row).Value
With CreateObject("Scripting.Dictionary")
    For i = 1 To UBound(x, 1)
        For k = 1 To UBound(x, 2)
            t = t & "~" & x(i, k)
        Next k
        .Item(t) = 1: t = vbNullString
    Next i
       'MsgBox Timer - tm: tm = Timer
    x = Sheets("Sheet1").Range("A1:C" & Sheets("Sheet1").Range("A" & Rows.Count).End(3).Row).Value:: ReDim y(1 To UBound(x, 1), 1 To UBound(x, 2))
    For i = 1 To UBound(x)
        For k = 1 To UBound(x, 2)
            t = t & "~" & x(i, k)
        Next k
        If Not .Exists(t) Then
            j = j + 1
            For k = 1 To UBound(x, 2): y(j, k) = x(i, k): Next k
        End If: t = vbNullString
    Next i
End With
On Error Resume Next
With Sheets("Sheet3")
    .UsedRange.ClearContents
    .Range("A2").Resize(j, UBound(x, 2)).Value = y()
    .Activate
End With
Sheets("Sheet1").Range("A1:C1").Copy Sheets("Sheet3").Range("A1:C1")

'MsgBox Timer - tm
End Sub
 

Ekli dosyalar

O kodlarla da elbet işlem yapılacaktır. Ancak kafam karıştı.
Aşağıda aynı olayın ADO yöntemiyle çözümü var.

Bu kodları deneyebilirsin.
C++: 
Sub FarkliOlanlarıListele()
    Dim i As Integer, Sorgu As String, Zaman As Double
    Dim adoCon As Object, adoRS As Object
   
    Application.ScreenUpdating = False
    Zaman = Timer
    Sheets("Sheet3").Cells.ClearContents
    Set adoCon = CreateObject("adodb.Connection")
    Set adoRS = CreateObject("adodb.recordset")
    adoCon.Open "provider=microsoft.ace.oledb.12.0;data source=" & _
    ThisWorkbook.FullName & ";extended properties=""excel 12.0;hdr=yes"""
    Sorgu = "select * from [Sheet1$] where not exists "
    Sorgu = Sorgu + "(select * from [Sheet2$] where [Sheet1$].[STOKKODU]=[Sheet2$].[STOKKODU] and [Sheet1$].[SATISFIYATI1]=[Sheet2$].[SATISFIYATI1])"
    adoRS.Open Sorgu, adoCon, 1, 1
    If adoRS.RecordCount > 0 Then
        Sheets("Sheet1").Range("A1:D1").Copy Sheets("Sheet3").Range("A1")
        Sheets("Sheet3").Range("A2").CopyFromRecordset adoRS
        Mesaj = "Fiyatı farklı olan" & Chr(10) & "Toplam : " & adoRS.RecordCount & " adet kayıt listelendi."
    Else
        Mesaj = "Farklı kayıt bulunamadı."
    End If
    Application.ScreenUpdating = True
    MsgBox Mesaj & Chr(10) & Chr(10) & "İşlem süresi: " & Format(Timer - Zaman, "0.00") & " saniye", vbInformation
          
    i = Empty: Zaman = Empty: Sorgu = "": Set adoCon = Nothing: Set adoRS = Nothing
End Sub
 
Kod: 
Sub ertert()
'Dim tm!: tm = Timer
    Dim x, y(), i&, j&, k&, t$
    x = Sheets("Sheet2").Range("A1:C" & Sheets("Sheet2").Range("A" & Rows.Count).End(3).Row).Value
    With CreateObject("Scripting.Dictionary")
        For i = 2 To UBound(x, 1)
            For k = 1 To UBound(x, 2)
                t = t & "~" & x(i, k)
            Next k
            .Item(t) = 1: t = vbNullString
        Next i
        'MsgBox Timer - tm: tm = Timer
        x = Sheets("Sheet1").Range("A1:D" & Sheets("Sheet1").Range("A" & Rows.Count).End(3).Row).Value:: ReDim y(1 To UBound(x, 1), 1 To UBound(x, 2))
        For i = 2 To UBound(x)
            For k = 1 To UBound(x, 2) - 1
                t = t & "~" & x(i, k)
            Next k
            If Not .Exists(t) Then
                j = j + 1
                For k = 1 To UBound(x, 2): y(j, k) = x(i, k): Next k
            End If: t = vbNullString
        Next i
    End With
    On Error Resume Next
    With Sheets("Sheet3")
        .UsedRange.ClearContents
        .Range("A2").Resize(j, UBound(x, 2)).Value = y()
        .Activate
    End With
    Sheets("Sheet1").Range("A1:D1").Copy Sheets("Sheet3").Range("A1:D1")

    'MsgBox Timer - tm
End Sub
 
veyselemre' Alıntı:
Kod: 
Sub ertert()
'Dim tm!: tm = Timer
    Dim x, y(), i&, j&, k&, t$
    x = Sheets("Sheet2").Range("A1:C" & Sheets("Sheet2").Range("A" & Rows.Count).End(3).Row).Value
    With CreateObject("Scripting.Dictionary")
        For i = 2 To UBound(x, 1)
            For k = 1 To UBound(x, 2)
                t = t & "~" & x(i, k)
            Next k
            .Item(t) = 1: t = vbNullString
        Next i
        'MsgBox Timer - tm: tm = Timer
        x = Sheets("Sheet1").Range("A1:D" & Sheets("Sheet1").Range("A" & Rows.Count).End(3).Row).Value:: ReDim y(1 To UBound(x, 1), 1 To UBound(x, 2))
        For i = 2 To UBound(x)
            For k = 1 To UBound(x, 2) - 1
                t = t & "~" & x(i, k)
            Next k
            If Not .Exists(t) Then
                j = j + 1
                For k = 1 To UBound(x, 2): y(j, k) = x(i, k): Next k
            End If: t = vbNullString
        Next i
    End With
    On Error Resume Next
    With Sheets("Sheet3")
        .UsedRange.ClearContents
        .Range("A2").Resize(j, UBound(x, 2)).Value = y()
        .Activate
    End With
    Sheets("Sheet1").Range("A1:D1").Copy Sheets("Sheet3").Range("A1:D1")

    'MsgBox Timer - tm
End Sub
Genişletmek için tıkla ...
Çok Teşekkürler Tam İstediğim Gibi Oldu
 
ÖmerFaruk' Alıntı:
a aynı olayın ADO yöntemiyle çözümü var.
Genişletmek için tıkla ...
ÖmerFaruk' Alıntı:
O kodlarla da elbet işlem yapılacaktır. Ancak kafam karıştı.
Aşağıda aynı olayın ADO yöntemiyle çözümü var.

Bu kodları deneyebilirsin.
C++: 
Sub FarkliOlanlarıListele()
    Dim i As Integer, Sorgu As String, Zaman As Double
    Dim adoCon As Object, adoRS As Object
  
    Application.ScreenUpdating = False
    Zaman = Timer
    Sheets("Sheet3").Cells.ClearContents
    Set adoCon = CreateObject("adodb.Connection")
    Set adoRS = CreateObject("adodb.recordset")
    adoCon.Open "provider=microsoft.ace.oledb.12.0;data source=" & _
    ThisWorkbook.FullName & ";extended properties=""excel 12.0;hdr=yes"""
    Sorgu = "select * from [Sheet1$] where not exists "
    Sorgu = Sorgu + "(select * from [Sheet2$] where [Sheet1$].[STOKKODU]=[Sheet2$].[STOKKODU] and [Sheet1$].[SATISFIYATI1]=[Sheet2$].[SATISFIYATI1])"
    adoRS.Open Sorgu, adoCon, 1, 1
    If adoRS.RecordCount > 0 Then
        Sheets("Sheet1").Range("A1:D1").Copy Sheets("Sheet3").Range("A1")
        Sheets("Sheet3").Range("A2").CopyFromRecordset adoRS
        Mesaj = "Fiyatı farklı olan" & Chr(10) & "Toplam : " & adoRS.RecordCount & " adet kayıt listelendi."
    Else
        Mesaj = "Farklı kayıt bulunamadı."
    End If
    Application.ScreenUpdating = True
    MsgBox Mesaj & Chr(10) & Chr(10) & "İşlem süresi: " & Format(Timer - Zaman, "0.00") & " saniye", vbInformation
         
    i = Empty: Zaman = Empty: Sorgu = "": Set adoCon = Nothing: Set adoRS = Nothing
End Sub
Genişletmek için tıkla ...
Merhaba Ömer Bey Ado Yöntemiyle yavaş Oldugu İçin İstemiştim Veysel bey Halletti Teşekkürler
 
ÖmerFaruk' Alıntı:
O kodlarla da elbet işlem yapılacaktır. Ancak kafam karıştı.
Aşağıda aynı olayın ADO yöntemiyle çözümü var.

Bu kodları deneyebilirsin.
C++: 
Sub FarkliOlanlarıListele()
    Dim i As Integer, Sorgu As String, Zaman As Double
    Dim adoCon As Object, adoRS As Object

    Application.ScreenUpdating = False
    Zaman = Timer
    Sheets("Sheet3").Cells.ClearContents
    Set adoCon = CreateObject("adodb.Connection")
    Set adoRS = CreateObject("adodb.recordset")
    adoCon.Open "provider=microsoft.ace.oledb.12.0;data source=" & _
    ThisWorkbook.FullName & ";extended properties=""excel 12.0;hdr=yes"""
    Sorgu = "select * from [Sheet1$] where not exists "
    Sorgu = Sorgu + "(select * from [Sheet2$] where [Sheet1$].[STOKKODU]=[Sheet2$].[STOKKODU] and [Sheet1$].[SATISFIYATI1]=[Sheet2$].[SATISFIYATI1])"
    adoRS.Open Sorgu, adoCon, 1, 1
    If adoRS.RecordCount > 0 Then
        Sheets("Sheet1").Range("A1:D1").Copy Sheets("Sheet3").Range("A1")
        Sheets("Sheet3").Range("A2").CopyFromRecordset adoRS
        Mesaj = "Fiyatı farklı olan" & Chr(10) & "Toplam : " & adoRS.RecordCount & " adet kayıt listelendi."
    Else
        Mesaj = "Farklı kayıt bulunamadı."
    End If
    Application.ScreenUpdating = True
    MsgBox Mesaj & Chr(10) & Chr(10) & "İşlem süresi: " & Format(Timer - Zaman, "0.00") & " saniye", vbInformation
       
    i = Empty: Zaman = Empty: Sorgu = "": Set adoCon = Nothing: Set adoRS = Nothing
End Sub
Genişletmek için tıkla ...

Bu kodun 50.000 satırda resmen kasmasının sebebi nedir? Yanlışı nerede yapıyorum?
30 satırda denedim - 100 satırda denedim -300 denedim sürekli süre arttı. 3.000 satırı denedim 36 saniye sürdü
50.000 satır kopyaladım. Excelim dondu kaldı.
 
Son düzenleme:
Cevap yazmak için giriş yap yada kayıt ol.
Geri
Üst