bir sütundaki tüm yazıları sırayla başka bir sayfada arama

[tebdilikıyafet]

arkadaşlar merhaba;

elimde 2 adet excel dosyası var. bunlar benzer dosyalar. ilk dosyanın A sütununda bulunan tüm verileri diğer dosyanın K sütununda sırasıyla aratmak istiyorum. eğer K sütununda eşleşme olursa, eşleşmenin olduğu tüm satırı başka bir sheet te kaydetmek istiyorum.

bunu nasıl yapabilirim? vba bilgim çok zayıf malesef..

 

[mancubus]

çok az bilgi verilmiş.

ben kopyalanacak sayfayı 3. bir kitap olarak değerlendirerek makro yazdım.

aşağıdaki kodu boş bir kitabın kod modülüne kopyalayarak makro içeren çalışma kitabı olarak kaydedin. A sütununun bulunduğu kitap ve sayfa ile K sütununun bulunduğu kitap ve sayfanın isimlerini kendi gerçek dosyalarınıza göre düzeltin.

eşleşen satırlar A'nın veya K'nın bulunduğu kitaba kopyalanacaksa kodların da buna göre revize edilmesi gerekir.

KitapA ve KitapK açık olmalıdır.

Sub kitap_kars_kopya()

Dim wb As Workbook, wb1 As Workbook, wb2 As Workbook
Dim ws As Worksheet, ws1 As Worksheet, ws2 As Worksheet
Dim sat As Long, satA As Long, satK As Long

Application.ScreenUpdating = False

Set wb = ThisWorkbook
Set ws = wb.Sheets("Sayfa1")

Set wb1 = Workbooks("KitapA.xlsx")
Set ws1 = wb1.Sheets("SayfaA")
satA = ws1.Cells(Rows.Count, "A").End(xlUp).Row

Set wb2 = Workbooks("KitapK.xlsx")
Set ws2 = wb2.Sheets("SayfaK")
satK = ws2.Cells(Rows.Count, "K").End(xlUp).Row

ws.Cells.Clear
sat = 1
For i = 1 To satA
    For j = 1 To satK
        If ws1.Cells(i, "A") = ws2.Cells(j, "K") Then
            ws2.Rows(j).Copy
            ws.Rows(sat).PasteSpecial Paste:=xlPasteAll
            sat = sat + 1
        End If
    Next j
Next i
Application.CutCopyMode = False

Application.ScreenUpdating = True

End Sub

 

[tebdilikıyafet]

çok teşekkür ederim işimi gördü. peki buna şu şekilde bir ilave yapabilirmiyiz. mesela A sütununda ki bir değer K da bulunamıyorsa 3. kitaba bu kez boş bir satır yapıştırılsın??

 

[tebdilikıyafet]

ben bunun için aşağıdaki gibi birşey yaptım. K'nın 2. sütunun boş bıraktım ve eğer hiç bir eşleşme olmazsa K nın 2. sütunun alıp 3. kitaba yapıştırıyor. bu boş satır K nın herhangi bir sütunu olarak ayarlanabilir ve kodda gerekli değişiklik yapılarak kullanılabilir.

Sub kitap_kars_kopya()

Dim wb As Workbook, wb1 As Workbook, wb2 As Workbook
Dim ws As Worksheet, ws1 As Worksheet, ws2 As Worksheet
Dim sat As Long, satA As Long, satK As Long, satcc As Long

Application.ScreenUpdating = False

Set wb = ThisWorkbook
Set ws = wb.Sheets("Sayfa1")

Set wb1 = Workbooks("KitapA.xlsx")
Set ws1 = wb1.Sheets("SayfaA")
satA = ws1.Cells(Rows.Count, "A").End(xlUp).Row

Set wb2 = Workbooks("KitapK.xlsx")
Set ws2 = wb2.Sheets("SayfaK")
satK = ws2.Cells(Rows.Count, "K").End(xlUp).Row

ws.Cells.Clear
sat = 1
satcc = 0
For i = 1 To satA

    For j = 1 To satK
        If ws1.Cells(i, "A") = ws2.Cells(j, "K") Then
            satcc = satcc + 1
            ws2.Rows(j).Copy
            ws.Rows(sat).PasteSpecial Paste:=xlPasteAll
            sat = sat + 1
        End If
        
    Next j
    If satcc = 0 Then
    ws2.Rows(2).Copy
    ws.Rows(sat).PasteSpecial Paste:=xlPasteAll
    sat = sat + 1
    End If
    
 satcc = 0
Next i
Application.CutCopyMode = False

Application.ScreenUpdating = True

End Sub