Arasın, bulamazsa Eklesin...

[ECYavuz]

İyi günler Arkadaşlar;

Aşağıdaki gibi bir kod ile ASIL_KİTAP (Sayfa1 - [A] sütunundaki) bilgileri;
HEDEF_KİTAP sayfalarının [A] sütunlarındaki bilgilerle karşılaştırıyorum.

ASIL_KİTAP ta yer alan bilgi HEDEF_KİTAP ta yer alıyorsa o satır boyanıyor.

Bu mantıkla benim istediğim ASIL_KİTAP da olmayıp da HEDEF_KİTAP ta olan
bilgilerin ASIL_KİTAP Sayfa1 in [A] sütunu sonuna eklenmesi....

Saygılar ve şimdiden teşekkürler...

Private Sub AraBulEkle_Click()

Dim ASIL_KİTAP As Workbook
Dim HEDEF_KİTAP As Workbook
Dim SVN, SAYFA As Worksheet
Dim SATIR As Integer
Dim BUL

Set ASIL_KİTAP = ActiveWorkbook
Set SVN = ASIL_KİTAP.Sheets("Sayfa1")
Set HEDEF_KİTAP = Workbooks.Open(ActiveWorkbook.Path & "\TaranacakKitap.xls", False, False)

ASIL_KİTAP.Activate
For SATIR = 1 To SVN.[A65536].End(3).Row
If SVN.Cells(SATIR, 1) <> "" Then

For Each SAYFA In HEDEF_KİTAP.Sheets
On Error Resume Next
Set BUL = SAYFA.Columns("A").Find(SVN.Cells(SATIR, 1))
If Not BUL Is Nothing Then
SAYFA.Cells(BUL.Row, 1).Interior.ColorIndex = 6
End If
Next
End If
Next
HEDEF_KİTAP.Close
Application.ScreenUpdating = True
MsgBox " İŞLEM TAMAMLANMIŞTIR.", vbInformation
End Sub

 

[uzmanamele]

merhaba
syn ECYavuz,
ASIL_K&#304;TAP daki verileri HEDEF_K&#304;TAP da kar&#351;&#305;la&#351;t&#305;rabiliyorsan&#305;z, for-next d&#246;ng&#252;s&#252; bitti&#287;inde HEDEF_K&#304;TAP kapanmadan kodlar&#305; tersden &#231;al&#305;&#351;t&#305;rarak yapabilirsiniz.
HEDEF_K&#304;TAP daki verileri ASIL_K&#304;TAP da aras&#305;n varsa vard&#305;r, yoksa listenin alt&#305;na eklesin.
sizin mevcut kodlar&#305;n&#305;z &#231;al&#305;&#351;&#305;yorsa tersden kodlar&#305; d&#252;zenlemeniz kolay olacakt&#305;r.

 

[ECYavuz]

If Not BUL Is Nothing Then

form&#252;l&#252;n&#252; 'Varsa' &#351;ekline nas&#305;l uyarlayabiliriz???

 

[uzmanamele]

merhaba
syn ECYavuz,
siz VBA'ya benden daha hakimsiniz, IIF &#351;eklinde deneyin.

 

[ECYavuz]

Kafa durunca ne yapsan bo&#351;... tak&#305;ld&#305;m kald&#305;m....

 

[ECYavuz]

Sevgili arkada&#351;lar, &#351;u ihtiyara bir yard&#305;m edecek yokmu?

1 nci mesajdaki kodu dikkate almay&#305;n....(isterseniz..)

ASIL_K&#304;TAP (Sayfa1 - [A] s&#252;tunundaki) bilgileri;
HEDEF_K&#304;TAP sayfalar&#305;n&#305;n [A] s&#252;tunlar&#305;ndaki bilgilerle kar&#351;&#305;la&#351;t&#305;raca&#287;&#305;z.

(Bunu ayn&#305; dosyada iki ayr&#305; sayfay&#305; kar&#351;&#305;la&#351;t&#305;rmak olarak da d&#252;&#351;&#252;nebilirsiniz.)

ASIL_K&#304;TAP da olmay&#305;p da HEDEF_K&#304;TAP ta olan [A] s&#252;tunundaki bilgi ASIL_K&#304;TAP Sayfa1 in [A] s&#252;tununun sonuna eklenecek....

Hepsi buuu...Sayg&#305;lar...

 

[ECYavuz]

Sanırım buldum...

Sanırım yanıt aşağıdaki gibi olacak. Daha denemedim ama Sayın Evren Gizlen verdiği yanıt ile sonuca ulaşabileceğim...

Private Sub AraBulEkle_Click()

Dim ASIL_KİTAP As Workbook
Dim HEDEF_KİTAP As Workbook
Dim SVN, SAYFA As Worksheet
Dim SATIR As Integer
Dim BUL

Set ASIL_KİTAP = ActiveWorkbook
Set SVN = ASIL_KİTAP.Sheets("Sayfa1")
Set HEDEF_KİTAP = Workbooks.Open(ActiveWorkbook.Path & "\TaranacakKitap.xls", False, False)

ASIL_KİTAP.Activate
For SATIR = 1 To SVN.[A65536].End(3).Row
If SVN.Cells(SATIR, 1) <> "" Then

For Each SAYFA In HEDEF_KİTAP.Sheets
On Error Resume Next
Set BUL = SAYFA.Columns("A").Find(SVN.Cells(SATIR, 1))
If BUL Is Nothing Then
SAYFA.Cells(BUL.Row, 1).Interior.ColorIndex = 6
End If
Next
End If
Next
HEDEF_KİTAP.Close
Application.ScreenUpdating = True
MsgBox " İŞLEM TAMAMLANMIŞTIR.", vbInformation
End Sub

 

[ECYavuz]

Ne dersiniz Evren hocam...???

 

[Orion1]

Aşağıdaki kodlar işinize yarar.

Sub tara()
Dim asil_kitap As Workbook, hdf_kitap As Workbook
Dim sat As Long, syf As Worksheet, k As Range, hcr As Range
Set asil_kitap = ThisWorkbook
Set hdf_ktp = Workbooks.Open("taranacak_kitap.xls")
ThisWorkbook.Activate
sat = Cells(65536, "A").End(xlUp).Row + 1
Application.ScreenUpdating = False
For Each syf In hdf_ktp.Worksheets
    For Each hcr In syf.Range("A1:A" & Cells(65536, "A").End(xlUp).Row)
        Set k = asil_kitap.Sheets("Sayfa1").Range("A1:A65536").Find(hcr.Value, , xlValues, xlWhole)
            If k Is Nothing Then
                If sat >= 65533 Then
                    MsgBox "Asıl Kitapta satır doldu başka kayıt yapamazsınız..!!", vbCritical, "DİKKAT"
                    GoTo son
                End If
                Cells(sat, "A").Value = hcr.Value
                
                sat = sat + 1
            End If
    Next hcr
Next syf
son:
Application.ScreenUpdating = True
Set asil_kitap = Nothing
Set hdf_kitap = Nothing
Set k = Nothing
End Sub

 

[ECYavuz]

Sanırım yanıt aşağıdaki gibi olacak. Daha denemedim ama Sayın Evren Gizlen verdiği yanıt ile sonuca ulaşabileceğim...

Ulaşamadım... Olmadı ama Sayın Evren Sağolun yeni verdiğiniz kodları deneyeceğim.. Saygılar..

 

[Orion1]

Ulaşamadım... Olmadı ama Sayın Evren Sağolun yeni verdiğiniz kodları deneyeceğim.. Saygılar..

Benim 9 numaralı mesajda verdiğim kodlar oluyor.
Çünkü deneyerek verdim kodları.

 

[ECYavuz]

Sayın Evren çok teşekkür ederim.
hdf_ktp .... hdf_kitap yapılınca çalışıyor.
Programa uyarladım (dediğim gibi konuyu okuduğunuzu görünce bu iş oldu demiştim.) sağolun...

Sub tara()
Dim asil_kitap As Workbook, hdf_kitap As Workbook
Dim sat As Long, syf As Worksheet, k As Range, hcr As Range
Set asil_kitap = ThisWorkbook
Set hdf_ktp = Workbooks.Open("taranacak_kitap.xls")
ThisWorkbook.Activate
sat = Cells(65536, "A").End(xlUp).Row + 1
Application.ScreenUpdating = False
For Each syf In hdf_ktp.Worksheets
For Each hcr In syf.Range("A1:A" & Cells(65536, "A").End(xlUp).Row)
Set k = asil_kitap.Sheets("Sayfa1").Range("A1:A65536").Find(hcr.Value, , xlValues, xlWhole)
If k Is Nothing Then
If sat >= 65533 Then
MsgBox "Asıl Kitapta satır doldu başka kayıt yapamazsınız..!!", vbCritical, "DİKKAT"
GoTo son
End If
Cells(sat, "A").Value = hcr.Value

sat = sat + 1
End If
Next hcr
Next syf
son:
Application.ScreenUpdating = True
Set asil_kitap = Nothing
Set hdf_kitap = Nothing
Set k = Nothing
End Sub

 

[Orion1]

Sayın Evren çok teşekkür ederim.
hdf_ktp .... hdf_kitap yapılınca çalışıyor.
Programa uyarladım (dediğim gibi konuyu okuduğunuzu görünce bu iş oldu demiştim.) sağolun...

Rica ederim.
İyi çalışmalar.