o2l3m
Altın Üye
- Katılım
- 2 Mart 2005
- Mesajlar
- 156
- Excel Vers. ve Dili
- Microsoft® Excel ® 2016 (16.0.5413.1000) MSO (16.0.5413.1000) 32 bit
- Altın Üyelik Bitiş Tarihi
- 14-10-2026
Merhaba;
Aşağıdaki kodu ChatGPT ile yazdırdım. Fakat F sütununa arattığım ve bulduğum değerlerin hücre adreslerini getiremedim.
Yardım edebilir misiniz?
Aşağıdaki kodu ChatGPT ile yazdırdım. Fakat F sütununa arattığım ve bulduğum değerlerin hücre adreslerini getiremedim.
Yardım edebilir misiniz?
Kod:
Function GetCellAddress(rowNum As Long, ws As Worksheet) As String
GetCellAddress = ws.Cells(rowNum, 1).Address
End Function
Sub AramaVeListeleme4()
Application.ScreenUpdating = False ' Ekran güncellemesini devre dışı bırak
Dim aranan As String
Dim klasorYolu As String
Dim dosyaYolu As String
Dim sonucHucresi As Range
Dim dosyaAdi As String
Dim wb As Workbook
' Aranacak değeri B3 hücresinden al
aranan = Range("B3").Value
' Klasör yolunu C3 hücresinden al
klasorYolu = Range("C3").Value
' Sonuçları D3 hücresinden başlayarak listeleyeceğimiz hücreyi belirleyin
Set sonucHucresi = Range("D3")
' Aranan değer bulunduğunda sayfa adlarını E3 ve sonraki hücrelere yazmak için değişken oluşturun
Dim sayfaAdi As String
Dim hucresi As Range ' Hücre adreslerini tutmak için değişken
' Hücre adreslerini F3 hücresinden başlayarak alt alta sıralı olarak eklemek için başlangıç hücresini belirleyin
Set hucresi = Range("F3")
' Dizindeki tüm dosyaları dolaşın
dosyaYolu = Dir(klasorYolu & "\*.xlsm")
Do While dosyaYolu <> ""
' Dosya adını alın
dosyaAdi = Mid(dosyaYolu, InStrRev(dosyaYolu, "\") + 1)
' Dosyayı açın (Salt okunur ve hızlı açma)
Set wb = Application.Workbooks.Open(Filename:=klasorYolu & "\" & dosyaAdi, ReadOnly:=True, UpdateLinks:=False)
' Aranan değeri bulmak için sayfaları dolaşın
For Each ws In wb.Sheets
' Aranan değeri sayfada bulunursa
If WorksheetFunction.CountIf(ws.UsedRange, aranan) > 0 Then
' Değerin bulunduğu sayfa adını alın
sayfaAdi = ws.Name
' Dosyanın linkini D3 hücresine ekle
sonucHucresi.Hyperlinks.Add Anchor:=sonucHucresi, Address:=klasorYolu & "\" & dosyaAdi, TextToDisplay:=dosyaAdi
' Sayfa adını sonuç hücresine yaz
sonucHucresi.Offset(0, 1).Value = sayfaAdi
' Hücre adresini ilgili hücreye yaz
Dim rowNum As Variant
rowNum = Application.Match(aranan, ws.UsedRange, 0)
If Not IsError(rowNum) Then
Dim cell As Range
Set cell = ws.Cells(rowNum, 1)
If Not cell Is Nothing Then
hucresi.Value = cell.Address
Else
hucresi.Value = "Bulunamadı"
End If
Else
hucresi.Value = "Bulunamadı"
End If
' Sonraki satıra geç
Set sonucHucresi = sonucHucresi.Offset(1)
Set hucresi = hucresi.Offset(1)
End If
Next ws
' Dosyayı kapatın
wb.Close SaveChanges:=False
' Sonraki dosyayı alın
dosyaYolu = Dir
Loop
Application.ScreenUpdating = True ' Ekran güncellemesini etkinleştir
' Arama tamamlandı mesajı
MsgBox "Arama tamamlandı.", vbInformation
End Sub
Ekli dosyalar
-
6.7 KB Görüntüleme: 4