• DİKKAT

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

Dosya Karşılaştırma Olmayanları Otomatik Ekletme

L

lfkaya

Katılım
11 Nisan 2016
Mesajlar
31
Excel Vers. ve Dili
2021
Arkadaşlar Excel 2 Dosyayı karşılaştırıp olmayanları nasıl ekleyebilirim
Örnek dosya ektedir
 

Ekli dosyalar

Arkadaşlar acil yardıma ihtiyacım var ama anlamadığı bir şey var ben mi soru sormasını bilmiyorum veya sorduğum mu çok zor şimdiye kadar sorduğum hiç bir soruma cevap alamadım
 
Merhaba
Ek dosyayı deneyelim.
http://www.dosyaupload.com/1UOf
"ORNEK2" klasörünü zip ten çıkarın, karşılaştırılacak 1 ve 2 excel dosyaları "DOSYALAR" klasörü
içindeyken "sonuç.xls" dosyasını açıp butona tıklayın. Karşılaştırılan dosyalara eklenen veriler
istediğiniz gibi mi?
Kod: 
[SIZE="2"]Private Sub CommandButton1_Click()
Cells.ClearContents
Cells.Borders.LineStyle = xlNone
Cells.Interior.Pattern = xlNone
Dim wb As Workbook
l = 1
Set ds = CreateObject("Scripting.FileSystemObject")
Set f = ds.GetFolder(ThisWorkbook.Path & "\DOSYALAR")
Set dc = f.Files
Set wb = ThisWorkbook
Application.ScreenUpdating = False
For Each DOSYA In dc
If Left(Split(DOSYA.Name, ".")(1), 3) = "xls" Then
Workbooks.Open DOSYA
If Z <> Empty Then p = ","
Z = Z & p & DOSYA.Name
Workbooks(DOSYA.Name).Sheets(1).UsedRange.Copy
wb.Sheets(1).Activate
Range("A" & Cells(Rows.Count, 1).End(3).Row + 1).PasteSpecial
Application.CutCopyMode = False
Range("H" & l & ":H" & Cells(Rows.Count, 1).End(3).Row + 1).Value = DOSYA.Name
l = Cells(Rows.Count, 1).End(3).Row + 1
If UBound(Split(Z, ",")) = 1 Then Exit For
End If
Next
x = Cells(Rows.Count, 1).End(3).Row
For a = 1 To x
If WorksheetFunction.CountIf(Range("b1:b" & x), Cells(a, "b")) = 1 Then
s = s + 1
Range("A" & a & ":H" & a).Copy
Range("I" & s).PasteSpecial
End If
Next
p = 0
For a2 = 1 To Cells(Rows.Count, "I").End(3).Row
If IsNumeric(Cells(a2, "I")) = True Then
dos = Split(Split(Z, ",")(p), ".")(0)
If Split(Cells(a2, "P"), ".")(0) = dos Then
dos = Split(Split(Z, ",")(p + 1), ".")(0)
With Workbooks(dos).ActiveSheet
i2 = .Cells(65500, 1).End(3).Row + 1
.Cells(i2, 1) = .Cells(i2 - 1, 1) + 1
.Cells(i2, 2) = Cells(a2, "J")
.Cells(i2, 3) = CDate(Cells(a2, "O"))
.Cells(i2, 4) = Cells(a2, "K")
.Cells(i2, 5) = Cells(a2, "N")
.Cells(i2, 6) = Cells(a2, "L")
.Cells(i2, 7) = Cells(a2, "M")
.Range("A" & i2 & ":G" & i2).Borders.Weight = xlThin
.Range("A" & i2 & ":G" & i2).Interior.ColorIndex = 4
End With
Else
dos = Split(Split(Z, ",")(p), ".")(0)
With Workbooks(dos).ActiveSheet
i2 = .Cells(65500, 1).End(3).Row + 1
.Cells(i2, 1) = .Cells(i2 - 1, 1) + 1
.Cells(i2, 2) = Cells(a2, "J")
.Cells(i2, 3) = Cells(a2, "L")
.Cells(i2, 4) = Cells(a2, "N")
.Cells(i2, 5) = Cells(a2, "O")
.Cells(i2, 6) = Cells(a2, "M")
.Cells(i2, 7) = CDate(Cells(a2, "K"))
.Range("A" & i2 & ":G" & i2).Borders.Weight = xlThin
.Range("A" & i2 & ":G" & i2).Interior.ColorIndex = 4
End With
End If: End If
Next
Application.ScreenUpdating = True
sor = MsgBox("İŞLEM BİTTİ DOSYALAR KAYDEDİLİP" & vbCrLf & " KAPATILSINMI?", vbYesNo)
If sor = vbYes Then
Application.DisplayAlerts = False
For kayıt = 0 To UBound(Split(Z, ","))
Workbooks(Split(Split(Z, ",")(kayıt), ".")(0)).Close SaveChanges:=True
Next
Application.DisplayAlerts = False
End If
End Sub[/SIZE]
 
PLİNT ilgine teşekkür ederim sanırım ben yanlış ifade ettim yapmış olduğunuz SONUC dosyasını calistirinca 1 ve 2 nolu dosyayı 1 ve 2 nolu sayfa olarak ayrı ayrı içeri almalı sonuc sayfasında göndermişolduğum dosyadaki ekrandaki gibi dizayn olması gerek ve mümkünse 2 nci bir tuşla dışarı aktar dedikten sonra 1 ve 2 nolu dosyayı ellemeden sonucda oluşan raporu örnek dosyadaki gözüktüğü gibi dışarı atmamız mümkünmü ayrıca karşılaştırma yapılırken ZRaporToplami Kısmı 0 olanları dikkate almamlı ve kontrol 1 nolu dosyada yer alan TerminalNo sutunu ile 2 nolu dosyada yer alan Kod sutunu karşılatırılmalı ve 1 nolu dosyada aynı kod 1 den fazla kullanılmışsa 1 i okunmalı

http://www.dosyaupload.com/2kPx
 
Son düzenleme:
Merhaba
Son mesajınızdan anladığım şekle göre aşağıdaki dosyayı deneyiniz.
(Z raporu toplamı "0" olanlar için özellikle deneme yapınız,kodlarda her iki dosyadan gelen toplamlar için geçerli şekildedir.)

http://s2.dosya.tc/server3/vv42ud/ORNEK3.zip.html
 
Son düzenleme:
Merhaba PLİNT ellerine sağlık sizlere fazla zahmet verdm kusura bakmayın hakkınızı helal edin. 2 ufak sorun hariç istediğim gibi olmuş 1. sorun 1. dosyada ZraporToplamı 0 olanları alıyor almaması lazım. Gene 1. Dosyada Terminal Nosu 1 den fazla kullanılmışsa hepsini alıyor TerminalNo 1 den fazla kullanılmışsa sadece 1 nci kullanımı almalı mümkünse içeri al duşunu çalıştırdığımızda 1 dosyayı Sayfa1 2 nci dosyayı Sayfa2 olarak ekletip karşılaştırmayı Sayfa1 ve Sayfa2 Üzerinde yaptırıp sonuc dosyasına karşılaştırmayla birlikte yazdırabilirmiyiz çıkışda sonuc dosyasını veriyi silmeden kaydetmeli

http://www.dosyaupload.com/2kSC
 
lfkaya' Alıntı:
... çıkışda sonuc dosyasını veriyi silmeden kaydetmeli
Genişletmek için tıkla ...
Merhaba
Yukarıdaki değişen kodları ve ek dosyayı inceleyiniz;
http://s2.dosya.tc/server3/vv42ud/ORNEK3.zip.html
Kod: 
[SIZE="2"]Private Sub CommandButton1_Click()
Application.DisplayAlerts = False
Application.ScreenUpdating = False
If Cells(Rows.Count, "B").End(3).Row > 2 Then
For n1 = 1 To 3
With Sheets(n1)
.Cells.ClearContents
.Cells.Borders.LineStyle = xlNone
.Cells.Interior.Pattern = xlNone
End With
Next
End If
Application.DisplayAlerts = False
Dim wb As Workbook
L = 1
Set ds = CreateObject("Scripting.FileSystemObject")
Set f = ds.GetFolder(ThisWorkbook.Path & "\DOSYALAR")
Set dc = f.Files
Set wb = ThisWorkbook
[COLOR="Blue"]'DÖNGÜ İLE KLASÖR İÇİNDEKİ DOSYALARI TEK TEK 
'AÇIP SAYFALARI KOPYALAYACAK[/COLOR] 
For Each DOSYA In dc
If Left(Split(DOSYA.Name, ".")(1), 3) = "xls" Then
Z = Z + 1
Workbooks.Open DOSYA
Workbooks(DOSYA.Name).Sheets(1).UsedRange.Copy [COLOR="Blue"]'KOPYALAYAN BÖLÜM[/COLOR]
wb.Sheets(1).Activate
Cells(Cells(Rows.Count, L).End(3).Row, L).PasteSpecial 
Application.CutCopyMode = False
L = L + 8
Workbooks(Split(DOSYA.Name, ".")(0)).Close False
If Z = 2 Then Exit For
End If
Next
Row = Cells(Rows.Count, "B").End(3).Row
If Row < Cells(Rows.Count, "J").End(3).Row Then Row = Cells(Rows.Count, "J").End(3).Row
[COLOR="Blue"]'ZTOPLAMI 0 VE KODLARI AYNI OLANLARIN SİLİNDİĞİ BÖLÜM[/COLOR]
[COLOR="Blue"]'YAN TABLODA BULUNMAYANLAR RENKLENECEK[/COLOR]
For z4 = Row To 1 Step -1
If Cells(z4, "D") = 0 Or Cells(z4, "D") = "" Then Range("B" & z4 & ":G" & z4).Delete Shift:=xlUp
If Cells(z4, "N") = 0 Or Cells(z4, "N") = "" Then Range("J" & z4 & ":O" & z4).Delete Shift:=xlUp
If WorksheetFunction.CountIf(Range("J2:J" & Row), Cells(z4, "B")) = 0 And Cells(z4, "B") <> "" Then Range("B" & z4 & ":G" & z4).Interior.ColorIndex = 3
If WorksheetFunction.CountIf(Range("B2:B" & Row), Cells(z4, "J")) = 0 And Cells(z4, "J") <> "" Then Range("J" & z4 & ":O" & z4).Interior.ColorIndex = 4
If WorksheetFunction.CountIf(Range("B2:B" & Row), Cells(z4, "B")) >= 2 Then Range("B" & z4 & ":G" & z4).Delete Shift:=xlUp
If WorksheetFunction.CountIf(Range("J2:J" & Row), Cells(z4, "J")) >= 2 Then Range("J" & z4 & ":O" & z4).Delete Shift:=xlUp
Next
Rows("1:1").Interior.ColorIndex = xlNone
[A2:A10000] = "": [A2] = 1: [I2:I10000] = "": [I2] = 1
Range("A2").AutoFill Destination:=Range("A2:A" & Cells(Rows.Count, "B").End(3).Row), Type:=xlFillSeries
Range("I2").AutoFill Destination:=Range("I2:I" & Cells(Rows.Count, "J").End(3).Row), Type:=xlFillSeries
[COLOR="Blue"]'AYIKALANAN VERİLER 2. VE 3. SAYFALARA KOPYALANIYOR[/COLOR]
Sheets(1).Columns("A:G").Copy: Sheets(2).Columns("A:G").PasteSpecial: Sheets(2).Cells.Interior.ColorIndex = xlNone
Sheets(1).Columns("I:O").Copy: Sheets(3).Columns("A:G").PasteSpecial: Sheets(3).Cells.Interior.ColorIndex = xlNone
Application.CutCopyMode = False
For Each z3 In Range("G2:J" & Row + 100)
If z3.Column = 7 And z3.Interior.ColorIndex = 3 Then _
Range("J" & z3.Row & ":O" & z3.Row).Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
If z3.Column = 10 And z3.Interior.ColorIndex = 4 Then _
Range("B" & z3.Row & ":G" & z3.Row).Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
If Cells(z3.Row, "B") = "" Then Range("B" & z3.Row & ":G" & z3.Row).Interior.ColorIndex = xlNone
If Cells(z3.Row, "J") = "" Then Range("J" & z3.Row & ":O" & z3.Row).Interior.ColorIndex = xlNone
Next
[COLOR="Blue"]'SIRA NO LAR YENİLENİYOR[/COLOR]
[A2:A10000] = "": [A2] = 1: [I2:I10000] = "": [I2] = 1
Range("A2").AutoFill Destination:=Range("A2:A" & Cells(Rows.Count, "B").End(3).Row), Type:=xlFillSeries
Range("I2").AutoFill Destination:=Range("I2:I" & Cells(Rows.Count, "J").End(3).Row), Type:=xlFillSeries
Application.ScreenUpdating = True
[F1].Select
MsgBox "VERİ ALMA İŞLEMİ BİTTİ"
End Sub

Private Sub CommandButton2_Click()
If Cells(Rows.Count, "A").End(3).Row < 3 And Cells(Rows.Count, "J").End(3).Row < 3 Then Exit Sub
Application.ScreenUpdating = False
Dim a As Workbook
Dim frmt As Long
Dim kopyayolla As String, dosyam As String
[COLOR="Blue"]'MAKROLAR YEDEK DOSYADA OLMAMASI İÇİN 1. SAYFANIN KOPYALANACAĞI
'YENİ BİR SAYFA OLUŞTURULUYOR.[/COLOR]
Sheets.Add After:=Sheets(1)
ActiveSheet.Name = "KARŞILAŞTIRMA"
Sheets(1).Columns("A:O").Copy
ActiveSheet.PasteSpecial
frmt = Application.DefaultSaveFormat
For Each a In Application.Workbooks
[COLOR="Blue"]'YEDEKLENECEK DOSYA OLUŞTURULUYOR[/COLOR]
dosyam = "RAPOR " & a.Name
Application.DefaultSaveFormat = Workbooks(a.Name).FileFormat
Workbooks(a.Name).Sheets(Array(2, 3, 4)).Copy
kopyayolla = ThisWorkbook.Path & "\" & dosyam
ActiveWorkbook.SaveCopyAs kopyayolla
ActiveWorkbook.Close savechanges:=False
Next
Application.DefaultSaveFormat = frmt
dosyam = vbNullString
kopyayolla = vbNullString
Application.DisplayAlerts = False
Sayfa1.Activate
[COLOR="Blue"]'OLUŞTURULAN 4. SAYFA SİLİNİYOR[/COLOR]
Sheets("KARŞILAŞTIRMA").Delete
Application.DisplayAlerts = True
Application.ScreenUpdating = True
      MsgBox "SAYFALAR RAPOR ADIYLA BU DOSYANIN YANINA KAYDEDİLDİ"

End Sub[/SIZE]
 
Son düzenleme:
PLİNT ellerine sağlık teşekkür ederim sonuc dosyasına verileri alıp karşılaştırdıkdan ve oluşan raporu farklı dosyaya kaydettikden sonr silme işlmeini gerçekleştirmese çok daha iyi olur ayrıca makro konusunda yetersiz bilgiye sahip olduğum için ve öğrenme amacı ile soruyorum oluşturduğun makroda verileri makronun hangi satırında içeri aldığı hangi sutunları nerden karşılaştığını açıklaman mümkünmü
 
Son düzenleme:
Merhaba PLİNT
Ellerine sağlık Teşekkür Ederim. İşimi gördü ek birşey rica etsem sana zahmet oluyor hakkını helal et sonuç dosyasında 2 nolu dosyanın var olduğunu düşünerek sadece 1 nolu dosyayı içeri aldırıp aynı işlemleri nasıl yapabiliriz
 
lfkaya' Alıntı:
sonuç dosyasında 2 nolu dosyanın var olduğunu düşünerek sadece 1 nolu dosyayı içeri aldırıp aynı işlemleri nasıl yapabiliriz
Genişletmek için tıkla ...
Merhaba
2.dosyanın "sonuc" dosyasında "I" ve "O" sütunlarında kayıtlı olduğını varsayarsak,
ilgili dosyanın yanındaki "DOSYALAR" klasöründe 1 no lu dosya tek başına olmalı ve
"Commandbutton1" kodlarında aşağıdaki döngü başlangıcını "2" yapmanız yeterli
Kod: 
Private Sub CommandButton1_Click()
Application.DisplayAlerts = False
Application.ScreenUpdating = False
If Cells(Rows.Count, "B").End(3).Row > 2 Then

For n1 [COLOR="Red"]= 2[/COLOR] To 3 

With Sheets(n1)
'....
'....
 
PLİNT Ellerine sağlık teşekkür ederim ben sayfa bazında düşünmüştüm yani 11 nolu mesajdaki dosyada 2 nolu dosyanın sayfa olarak var olduğunu 1 nolu sayfanın 1 nolu sayfa diye ayrı bir sayfaya alınmasını ve 1 ve 2 nolu sayfanın karşılaştırılmasını kastetmiştim yani 2 dosya içeri sayfa olarak alınmayacak 2 nci sayfa var sadece 1n ci sayfa ayrı bir sayfaya alınacak ve gerisi olduğu gibi karşılaştırılacak ayrıca içeri alınan dosyaların ismini 1 ve 2 şeklinde değil isim olarak değiştirmek istersem makroda değiştirmem mümkünmü
 
Son düzenleme:
Cevap yazmak için giriş yap yada kayıt ol.
Geri
Üst