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
Altın Üyelik Bitiş Tarihi
22-11-2022
Ö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

ÖmerFaruk

ÖmerFaruk

Destek Ekibi
Destek Ekibi
Katılım
22 Ekim 2017
Mesajlar
4,779
Excel Vers. ve Dili
Microsoft 365 Tr-64
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
 
veyselemre

veyselemre

Özel Üye
Katılım
9 Mart 2005
Mesajlar
3,647
Excel Vers. ve Dili
Pro Plus 2021
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
 
M

mukoli

Katılım
4 Eylül 2020
Mesajlar
394
Excel Vers. ve Dili
Excel 2016
Altın Üyelik Bitiş Tarihi
22-11-2022
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
 
M

mukoli

Katılım
4 Eylül 2020
Mesajlar
394
Excel Vers. ve Dili
Excel 2016
Altın Üyelik Bitiş Tarihi
22-11-2022
Ö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

ÖmerFaruk

Destek Ekibi
Destek Ekibi
Katılım
22 Ekim 2017
Mesajlar
4,779
Excel Vers. ve Dili
Microsoft 365 Tr-64
Ö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.
Üst