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

mukoli · 20 Ağustos 2021

Merhabalar Ekteki Dosyamda 2 Çalışma Sayfam Var BUnlarla Karşılaştırma Yaparak Sayfa1 A ile Sayfa 2 A Sütunu Eşleştirip Her İki Sayfadaki C Sütunundaki Farkı Sayfa 3 Yazdırmasını İstiyorum Makro Vardır . İstediğim Şeyi Yapıyor Fakat Sayfa 1 De 4 Sütun Var Sayfa 2 De 3 Sütun Oyuzden tarih Olan Farklılıgıda Sayıyor.
Benim İstediğim Sayfa1 De ki (D) Sütunu i Dikkate Almasın

Kod:

Sub ertert()
'Dim tm!: tm = Timer
Dim x, y(), i&, j&, k&, t$
x = Sheets("Sheet2").Range("A1:C9999").CurrentRegion.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:C99999").CurrentRegion.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("A1").Resize(j, UBound(x, 2)).Value = y()
    .Activate
  
End With

'MsgBox Timer - tm
End Sub

ÖmerFaruk · 20 Ağustos 2021

C#:

'Aşağıdaki satırları altakilerle değiştirin'
x = Sheets("Sheet2").Range("A1:C9999").CurrentRegion.Value
x = Sheets("Sheet1").Range("A1:C99999").CurrentRegion.Value : ReDim y(1 To UBound(x, 1), 1 To UBound(x, 2))
    
x = Sheets("Sheet2").Range("A1:C" & Sheets("Sheet2").Range("A" & Rows.Count).End(3).Row).Value
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))

mukoli · 20 Ağustos 2021

Çok Teşekkür Ederim İlginize Mükemmel Oldu Elinize Sağlık .Bir Şey Daha İstesem Ayıp Olurmu Acaba Sayfa 3 Kopyalarken Başlıkları Aldırabilirmiyiz

ÖmerFaruk · 20 Ağustos 2021

Kodlarınızdaki With-End olan kısmı silin ve aşağıdkai kodu oraya yapıştırın.

C#:

Sheets("Sheet1").Range("A1:C1").Copy Sheets("Sheet3").Range("A1:C1")
With Sheets("She1et3")
    .UsedRange.ClearContents
    .Range("A2").Resize(j, UBound(x, 2)).Value = y()
    .Activate
End With

Haluk · 20 Ağustos 2021

C sütunları arasındaki fark yazılmayacak mıydı?

.

mukoli · 20 Ağustos 2021

ÖmerFaruk' Alıntı:
Kodlarınızdaki With-End olan kısmı silin ve aşağıdkai kodu oraya yapıştırın.

C#:

Sheets("Sheet1").Range("A1:C1").Copy Sheets("Sheet3").Range("A1:C1") With Sheets("She1et3") .UsedRange.ClearContents .Range("A2").Resize(j, UBound(x, 2)).Value = y() .Activate End With

Merhaba Tekrardan Uyguladım A2 Başlayarak Kopyalıyor Ama Sütun İsimleri Boş Geliyor

mukoli · 20 Ağustos 2021

Haluk' Alıntı:
C sütunları arasındaki fark yazılmayacak mıydı?

.

Merhaba Evet Doğrudur

Haluk · 20 Ağustos 2021

O zaman ADO ile "Left Join" yaparak işi halledebiliriz....

Not: Kodun başında belirtilen referansı VBA editöründe Tools>>References bölümünden eklemeyi unutmayın...

C++:

Sub Test()
'   Haluk 19/08/2021
'   sa4truss@ gmail.com
'
'   Reference: Microsoft ActiveX Data Objects 2.8 Library
'
    Dim strSQL As String
    Dim strQuery As String
    Dim adoCN As ADODB.Connection
    Dim RS As ADODB.Recordset
   
    Sheets("Sheet3").Range("A2:G" & Rows.Count).ClearContents
   
    Set adoCN = New ADODB.Connection
   
    adoCN.Provider = "Microsoft.ACE.OLEDB.12.0"
    adoCN.Properties("Extended Properties") = "Excel 8.0; HDR= Yes;"
    adoCN.ConnectionString = ThisWorkbook.FullName
    adoCN.CursorLocation = adUseClient
   
    adoCN.Open
   
    strSQL = "Select Table1.[STOKKODU], Table1.[MALINCINSI], Table1.[SATISFIYATI1]-Table2.[SATISFIYATI1] As [FARK]" & _
             "From [Sheet1$] as Table1 " & _
             "Left Join " & _
             "[Sheet2$] As Table2 " & _
             "On Table1.[STOKKODU] = Table2.[STOKKODU] Where Table1.[STOKKODU] Is Not Null"
   
    Set RS = New ADODB.Recordset
   
    RS.CursorType = adOpenForwardOnly
    RS.LockType = adLockReadOnly
    RS.ActiveConnection = adoCN
    RS.Source = strSQL
   
    RS.Open
   
    For j = 0 To RS.Fields.Count - 1
        Sheets("Sheet3").Cells(1, j + 1) = RS.Fields(j).Name
    Next
   
    Sheets("Sheet3").Range("A2").CopyFromRecordset RS
   
    RS.Close
    adoCN.Close
    Set RS = Nothing
End Sub

.

ÖmerFaruk · 20 Ağustos 2021

C++:

With Sheets("She1et3")
    .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")

mukoli · 20 Ağustos 2021

Merhaba Haluk Bey Elinize Sağlık Sizin Kod Çok Daha İyi Fakat C Sütunundaki Fiyat + - Fark Olarak Değil Değişim Farkı Olarak Fiyat Değişen Farkları Görmek İstiyorum

Haluk · 20 Ağustos 2021

Anlamadım..... örnek verirmisiniz?

.

mukoli · 20 Ağustos 2021

ÖmerFaruk' Alıntı:

C++:

With Sheets("She1et3")
    .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")

Çok Teşekkürler Ömer Bey Şimdi Oldu Tekrardan Elinize Sağlık

mukoli · 20 Ağustos 2021

Haluk' Alıntı:
Anlamadım..... örnek verirmisiniz?

.

Tabiki Sizinki Çıkarma İşlemi Yapıyor. Benim İstediğim Sayfa1 A Kolonunda Barkodla Sayfa 2 nın A Kolonu Eşleşip C Kolonu Aynı Fiyat mı Eğer Aynı Fiyatsa Sıkıntı Yok Fiyat Farkı Varsa Değişen varsa Sayfa 3 Kopyalasın. Bu şekilde Fiyatı Değişen Ürünleri Bulmak İsityorum Umarım Anlatabilmişimdir.

ÖmerFaruk · 20 Ağustos 2021

Soru sahibinin ilk kodlarında doğru verinin geldiğini kabul ederek ki bu yönde bir şikayeti yok, Sayfa1 deki tablodaki her bir satır ile Sayfa2 de verileri karşılaştırıp fiyatları farklı olan varsa Sayfa1 deki haliyle A-B-C sütunlarının sayfa 3 te listelenmesini istiyor.

mukoli · 20 Ağustos 2021

ÖmerFaruk' Alıntı:
Soru sahibinin ilk kodlarında doğru verinin geldiğini kabul ederek ki bu yönde bir şikayeti yok, Sayfa1 deki tablodaki her bir satır ile Sayfa2 de verileri karşılaştırıp fiyatları farklı olan varsa Sayfa1 deki haliyle A-B-C sütunlarının sayfa 3 te listelenmesini istiyor.

Teşekkür Ederim Ömer Bey KOlay Gelsin Sizlere

Haluk · 20 Ağustos 2021

mukoli' Alıntı:
Tabiki Sizinki Çıkarma İşlemi Yapıyor. Benim İstediğim Sayfa1 A Kolonunda Barkodla Sayfa 2 nın A Kolonu Eşleşip C Kolonu Aynı Fiyat mı Eğer Aynı Fiyatsa Sıkıntı Yok Fiyat Farkı Varsa Değişen varsa Sayfa 3 Kopyalasın. Bu şekilde Fiyatı Değişen Ürünleri Bulmak İsityorum Umarım Anlatabilmişimdir.

Kafayı taktım......Ekli revizyon oluyor mu ?

C++:

Sub Test()
'   Haluk 19/08/2021
'   sa4truss@ gmail.com
'
'   Reference: Microsoft ActiveX Data Objects 2.8 Library
'
    Dim strSQL As String
    Dim strQuery As String
    Dim adoCN As ADODB.Connection
    Dim RS As ADODB.Recordset
 
    Sheets("Sheet3").Range("A2:C" & Rows.Count).ClearContents
 
    Set adoCN = New ADODB.Connection
 
    adoCN.Provider = "Microsoft.ACE.OLEDB.12.0"
    adoCN.Properties("Extended Properties") = "Excel 8.0; HDR= Yes;"
    adoCN.ConnectionString = ThisWorkbook.FullName
    adoCN.CursorLocation = adUseClient
 
    adoCN.Open
 
    strSQL = "Select Table1.[STOKKODU], Table1.[MALINCINSI] " & _
             "From [Sheet1$] as Table1 " & _
             "Left Join " & _
             "[Sheet2$] As Table2 " & _
             "On Table1.[STOKKODU] = Table2.[STOKKODU] Where Table1.[SATISFIYATI1] <> Table2.[SATISFIYATI1]"
 
    Set RS = New ADODB.Recordset
 
    RS.CursorType = adOpenForwardOnly
    RS.LockType = adLockReadOnly
    RS.ActiveConnection = adoCN
    RS.Source = strSQL
 
    RS.Open
 
    For j = 0 To RS.Fields.Count - 1
        Sheets("Sheet3").Cells(1, j + 1) = RS.Fields(j).Name
    Next
 
    Sheets("Sheet3").Range("A2").CopyFromRecordset RS
 
    RS.Close
    adoCN.Close
    Set RS = Nothing
End Sub

.

mukoli · 20 Ağustos 2021

Haluk' Alıntı:

Kafayı taktım......Ekli revizyon oluyor mu ?

C++:

Sub Test()
'   Haluk 19/08/2021
'   sa4truss@ gmail.com
'
'   Reference: Microsoft ActiveX Data Objects 2.8 Library
'
    Dim strSQL As String
    Dim strQuery As String
    Dim adoCN As ADODB.Connection
    Dim RS As ADODB.Recordset

    Sheets("Sheet3").Range("A2:C" & Rows.Count).ClearContents

    Set adoCN = New ADODB.Connection

    adoCN.Provider = "Microsoft.ACE.OLEDB.12.0"
    adoCN.Properties("Extended Properties") = "Excel 8.0; HDR= Yes;"
    adoCN.ConnectionString = ThisWorkbook.FullName
    adoCN.CursorLocation = adUseClient

    adoCN.Open

    strSQL = "Select Table1.[STOKKODU], Table1.[MALINCINSI] " & _
             "From [Sheet1$] as Table1 " & _
             "Left Join " & _
             "[Sheet2$] As Table2 " & _
             "On Table1.[STOKKODU] = Table2.[STOKKODU] Where Table1.[SATISFIYATI1] <> Table2.[SATISFIYATI1]"

    Set RS = New ADODB.Recordset

    RS.CursorType = adOpenForwardOnly
    RS.LockType = adLockReadOnly
    RS.ActiveConnection = adoCN
    RS.Source = strSQL

    RS.Open

    For j = 0 To RS.Fields.Count - 1
        Sheets("Sheet3").Cells(1, j + 1) = RS.Fields(j).Name
    Next

    Sheets("Sheet3").Range("A2").CopyFromRecordset RS

    RS.Close
    adoCN.Close
    Set RS = Nothing
End Sub

Ekli dosyayı görüntüle 229548

.

Evet Haluk Bey Oldu Ama Satısfiyat Alanıda Gelirse Tam Olucak Şİmdi Tam İsteiğimiz Gibi Çalışıyor Sadece Satış Fiyat Alanı Eksik Sayfa 3 Getirilen Verilerin Sayfa 1 Deki Fiyat Alanı Karşılıgı Olursa C Sütununda

Haluk · 20 Ağustos 2021

O zaman;

C++:

Sub Test()
'   Haluk 19/08/2021
'   sa4truss@ gmail.com
'
'   Reference: Microsoft ActiveX Data Objects 2.8 Library
'
    Dim strSQL As String
    Dim strQuery As String
    Dim adoCN As ADODB.Connection
    Dim RS As ADODB.Recordset
  
    Sheets("Sheet3").Range("A2:C" & Rows.Count).ClearContents
  
    Set adoCN = New ADODB.Connection
  
    adoCN.Provider = "Microsoft.ACE.OLEDB.12.0"
    adoCN.Properties("Extended Properties") = "Excel 8.0; HDR= Yes;"
    adoCN.ConnectionString = ThisWorkbook.FullName
    adoCN.CursorLocation = adUseClient
  
    adoCN.Open
  
    strSQL = "Select Table1.[STOKKODU], Table1.[MALINCINSI], Table1.[SATISFIYATI1] " & _
             "From [Sheet1$] as Table1 " & _
             "Left Join " & _
             "[Sheet2$] As Table2 " & _
             "On Table1.[STOKKODU] = Table2.[STOKKODU] Where Table1.[SATISFIYATI1] <> Table2.[SATISFIYATI1]"
  
    Set RS = New ADODB.Recordset
  
    RS.CursorType = adOpenForwardOnly
    RS.LockType = adLockReadOnly
    RS.ActiveConnection = adoCN
    RS.Source = strSQL
  
    RS.Open
  
    For j = 0 To RS.Fields.Count - 1
        Sheets("Sheet3").Cells(1, j + 1) = RS.Fields(j).Name
    Next
  
    Sheets("Sheet3").Range("A2").CopyFromRecordset RS
  
    RS.Close
    adoCN.Close
    Set RS = Nothing
End Sub

mukoli · 20 Ağustos 2021

Tamamdır Elinize Koluna Sağlık Onuda Ben Ekledim Şimdi Tam İstediğimiz Gibi oldu Çok teşekkür Ederim Hakkınızı Helal Ediniz

Haluk · 20 Ağustos 2021

Ama, ben olsam olayı net görmek için böyle kullanırdım;

C++:

Sub Test2()
'   Haluk 19/08/2021
'   sa4truss@ gmail.com
'
'   Reference: Microsoft ActiveX Data Objects 2.8 Library
'
    Dim strSQL As String
    Dim strQuery As String
    Dim adoCN As ADODB.Connection
    Dim RS As ADODB.Recordset
   
    Sheets("Sheet3").Range("A2:C" & Rows.Count).ClearContents
   
    Set adoCN = New ADODB.Connection
   
    adoCN.Provider = "Microsoft.ACE.OLEDB.12.0"
    adoCN.Properties("Extended Properties") = "Excel 8.0; HDR= Yes;"
    adoCN.ConnectionString = ThisWorkbook.FullName
    adoCN.CursorLocation = adUseClient
   
    adoCN.Open
   
    strSQL = "Select Table1.[STOKKODU], Table1.[MALINCINSI], Table1.[SATISFIYATI1] As [İLK BF], Table2.[SATISFIYATI1] As [Son BF] " & _
             "From [Sheet1$] as Table1 " & _
             "Left Join " & _
             "[Sheet2$] As Table2 " & _
             "On Table1.[STOKKODU] = Table2.[STOKKODU] Where Table1.[SATISFIYATI1] <> Table2.[SATISFIYATI1]"
   
    Set RS = New ADODB.Recordset
   
    RS.CursorType = adOpenForwardOnly
    RS.LockType = adLockReadOnly
    RS.ActiveConnection = adoCN
    RS.Source = strSQL
   
    RS.Open
   
    For j = 0 To RS.Fields.Count - 1
        Sheets("Sheet3").Cells(1, j + 1) = RS.Fields(j).Name
    Next
   
    Sheets("Sheet3").Range("A2").CopyFromRecordset RS
   
    RS.Close
    adoCN.Close
    Set RS = Nothing
End Sub

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

mukoli

Ekli dosyalar

ÖmerFaruk

Destek Ekibi

mukoli

ÖmerFaruk

Destek Ekibi

Haluk

Özel Üye

mukoli

mukoli

Haluk

Özel Üye

ÖmerFaruk

Destek Ekibi

mukoli

Haluk

Özel Üye

mukoli

mukoli

ÖmerFaruk

Destek Ekibi

mukoli

Haluk

Özel Üye

mukoli

Haluk

Özel Üye

mukoli

Haluk

Özel Üye