Bir dosyadaki ismin,başka bir dosyadaki karşılığını yazdırmak

[10erS]

Selamlar;
2 farklı dosyam var.
1- 1.nci dosyaya yazdığım isimler 2.nci dosyadan (7 sayfalı) bulunup, karşılığı olan banka ve iban no'ları yazdırılacak.
2- Tablodaki en alt yani toplamların olduğu satır sürekli gözükecek.
Emeği geçenlere şimdiden çok teşekkürler.

 

[halit3]

Selamlar;
2 farklı dosyam var.
1- 1.nci dosyaya yazdığım isimler 2.nci dosyadan (7 sayfalı) bulunup, karşılığı olan banka ve iban no'ları yazdırılacak.
2- Tablodaki en alt yani toplamların olduğu satır sürekli gözükecek.
Emeği geçenlere şimdiden çok teşekkürler.

Her iki dosya mütlaka yan yana olmalı

ekli dosyanızı kontrol ediniz.

Private Sub CommandButton1_Click()
Application.ScreenUpdating = False
Application.DisplayAlerts = False
 
Sayfa_Adı1 = "Sayfa1"
Sayfa_Adı2 = "Sayfa2"
Worksheets(Sayfa_Adı2).Range("A3:E5000").ClearContents
Worksheets(Sayfa_Adı2).Range("A3:E5000").Font.ColorIndex = 0
  
For j = 4 To Worksheets(Sayfa_Adı1).Cells(Rows.Count, "A").End(3).Row
ThisWorkbook.Sheets(Sayfa_Adı2).Cells(j - 1, 1).Value = j - 3
ThisWorkbook.Sheets(Sayfa_Adı2).Cells(j - 1, 2).Value = ThisWorkbook.Sheets(Sayfa_Adı1).Cells(j, 1).Value
ThisWorkbook.Sheets(Sayfa_Adı2).Cells(j - 1, 5).Value = ThisWorkbook.Sheets(Sayfa_Adı1).Cells(j, 16).Value
Next j
son = Worksheets(Sayfa_Adı2).Cells(Rows.Count, "B").End(3).Row
Klasor = ThisWorkbook.Path
Dosya = "TÜM HESAP NOLARI"

For i = Len(ThisWorkbook.Name) To 1 Step -1
If Mid(ThisWorkbook.Name, i, 1) = "." Then
'Dosya_adi = Mid(ThisWorkbook.Name, 1, i - 1)
Uzanti = Mid(ThisWorkbook.Name, i, Len(ThisWorkbook.Name))
Exit For
End If
Next
 
Dim wb As Workbook
On Error Resume Next
Set wb = Workbooks.Open(Klasor & "\" & Dosya & Uzanti)
yeni_dosya_adı = ActiveWorkbook.Name
For i = 3 To son
aranan = ThisWorkbook.Sheets(Sayfa_Adı2).Cells(i, 2).Value
deg = 0
For r = 1 To Workbooks(yeni_dosya_adı).Sheets.Count
Set k = Workbooks(yeni_dosya_adı).Sheets(r).Range("A:IV").Find(aranan, , xlValues, xlWhole)
If Not k Is Nothing Then
adr = k.Address
Do
deg = 1
ThisWorkbook.Sheets(Sayfa_Adı2).Cells(i, 3).Value = Workbooks(yeni_dosya_adı).Sheets(r).Cells(k.Row, k.Column + 1).Value
ThisWorkbook.Sheets(Sayfa_Adı2).Cells(i, 4).Value = Workbooks(yeni_dosya_adı).Sheets(r).Cells(k.Row, k.Column + 2).Value
Set k = Workbooks(yeni_dosya_adı).Sheets(i).Range("A:IV").FindNext(k)
Loop While Not k Is Nothing And k.Address <> adr
End If
Next r
If deg = 0 Then
ThisWorkbook.Sheets(Sayfa_Adı2).Cells(i, 3).Value = "YOK"
ThisWorkbook.Sheets(Sayfa_Adı2).Cells(i, 4).Value = "YOK"
ThisWorkbook.Sheets(Sayfa_Adı2).Cells(i, 3).Font.ColorIndex = 3
ThisWorkbook.Sheets(Sayfa_Adı2).Cells(i, 4).Font.ColorIndex = 3
End If

Next i
Set k = Nothing
Windows(wb.Name).Visible = True
wb.Close False
Application.ScreenUpdating = True
Application.DisplayAlerts = True
MsgBox "Listeleme Yapıldı.."
End Sub

 

[10erS]

Dosyayı açtığımda böyle bir yazı çıkıyor ve çalışmıyor.
Bu işlemi formüllü yapabilmem mümkün mü?

 

[halit3]

Araçlar/makro/güvenlik/güvenlik düzeyi

orta seçeneğindeki tiki işaretleyin
sonra

Araçlar/makro/güvenlik/güvenilen yayıncılar

bölümündeki aldaki iki seçeneğide işiratleyin

sonra

dosyayı kapatıp yiniden açınız.

gelen seçenekten makroları etkinleştir düğmesini tıklayınız.

 

[10erS]

Üstadım;
Ellerine, emeğine sağlık. Çok güzel oldu.
Allah klavyene zeval vermesin.

 

[halit3]

Üstadım;
Ellerine, emeğine sağlık. Çok güzel oldu.
Allah klavyene zeval vermesin.

Teşekkürler Sayın 10ers

Dairede iki bilgisayar var ikisininde kılavyesi varklı bazen yazım ve imla hatasını dikkat etmeden yapıyorum.

İyi çalışmalar diliyorum.