• 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

M

mukoli

Katılım
4 Eylül 2020
Mesajlar
394
Excel Vers. ve Dili
Excel 2016
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
 

Ekli dosyalar

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))
 
Ç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
 
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
 
C sütunları arasındaki fark yazılmayacak mıydı?

.
 
Ö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
Genişletmek için tıkla ...
Merhaba Tekrardan Uyguladım A2 Başlayarak Kopyalıyor Ama Sütun İsimleri Boş Geliyor
 
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


Capture.PNG


.
 
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")
 
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
 
Anlamadım..... örnek verirmisiniz?

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

.
Genişletmek için tıkla ...
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.
 
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.
 
Ö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.
Genişletmek için tıkla ...
Teşekkür Ederim Ömer Bey KOlay Gelsin Sizlere
 
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.
Genişletmek için tıkla ...



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



Capture.PNG

.
 
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

.
Genişletmek için tıkla ...
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
 
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



Capture.PNG
 
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
 
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



Capture.PNG
 
Cevap yazmak için giriş yap yada kayıt ol.
Geri
Üst