• DİKKAT

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

Başka bir exceli bulmak, açmak ve içindeki ilgili veriyi almak hakkında lütfen yardım

Katılım
25 Ekim 2010
Mesajlar
2
Excel Vers. ve Dili
2007 türkçe
Merhabalar,
Konuyla ilgili forumda gerçekten çok fazla örnek ve çözüm var ancak benim aradığım şey bir kaç tane kodu birleştirmeyi gerektirdiği ve de benim de makro bilgimin yetersiz kalması sebebiyle sıkıntı yaşamaktayım.

Yapmak istediğim şeyi anlatmaya çalışacağım, yardım edebilecek herkese çok teşekkür ederim.

Elimde yaklaşık olarak 900-950 tane bire bir aynı formatta exceller olacak, bunlar ise 3 tane klasör içine dağılacak (a klasöründe 300 tane, b kalsöründe 350 tane gibi..) bütün excellerin adı 8 haneli bir rakam dizisinden oluşacak. Benim yapmak istediğim şey; bir arama excelim olacak, seçili bir hücreye 8 haneli rakamı yazdığım zaman, o üç tane klasörün içinde ilgili (dosya adı aynı olan) exceli bulacak, o excelin 4. sayfasındaki A1:B4 hücrelerindeki verileri getirecek. Esasında işin bu kısmını sadece tek bir klasördeki, tek bir excel için yapabildim ama 3 tane klasör içindeki doğru exceli bulmayı yapamadım. Bir de buna ek olarak verileri çektiği exceli tıklayınca açmamı sağlayacak (köprü gibi) bir buton yapmak istiyorum. 2 haftadır uğraşıyorum ama bir türlü başaramadım yardım edebilirseniz çok mutlu olacağım. Bu arada, bu klasörler,exceller ve arama exceli server "\\Sb0002net01\" üzerinde olacak (makroyu etkiler mi bilemediğim için yazmak istedim).

Saygılarımla.
 
3 klasör içinde Arama Tarama yapmak

Ekteki dosyayı ve makrosunu geliştirmek suretiyle işinizi göreceğinizi umuyorum.

sağlıklı günler..
Nail
 

Ekli dosyalar

Ekteki dosyayı ve makrosunu geliştirmek suretiyle işinizi göreceğinizi umuyorum.

sağlıklı günler..
Nail

Yardımınız için çok teşekkür ederim, bir sorum olacak acaba aşağıya liste şeklinde gelen dosyaların köprü gibi yani tıklanabilir ve tıklandığında açılabilir şekilde olması mümkün olabilir mi?

İyi çalışmalar.
 
Kodları aşağıdaki ile değiştirin, Kolay gelsin
N.S.

Sub AraTara()
strtm = Time
Application.ScreenUpdating = False
Application.DisplayAlerts = False
tmlD = "AraTara.xls"

Windows(tmlD).Activate
Sheets("PRM").Select

klasr1 = Cells(3, "b") ' girilmeli
klasor = klasr1
GoSub klasör_ara
GoSub Dosya_isimleri

klasr2 = Cells(4, "b") ' girilmeli
klasor = klasr2
GoSub klasör_ara
GoSub Dosya_isimleri

klasr3 = Cells(5, "b") ' girilmeli
klasor = klasr3
GoSub klasör_ara
GoSub Dosya_isimleri

Cells(1, 2).Select
AraDsy = Cells(1, "b") ' aranacak dosya adı
araRow = "11:" & Rows.Count
Set bul = Sheets("PRM").Rows(araRow).Find(AraDsy)
If Not bul Is Nothing Then
Application.Goto Sheets("PRM").Range(bul.Address)
adr = ActiveCell.Address
Else
adr = Empty
End If
acK = Mid(adr, 2, InStr(2, adr, "$") - 2)
acR = Mid(adr, InStr(2, adr, acK & "$") + 2, 3)

acDos = AraDsy
GoSub acikD_check
'GoSub xldosya_ac

Application.Calculation = xlCalculationAutomatic
Application.WindowState = xlMaximized
MsgBox islem & " İşlem Tamamlandı." & strtm & ".." & Time

End


xldosya_ac:
If InStr(1, acDos, "xls") = 0 And InStr(1, acDos, "xlsx") = 0 Then Return
If acikD = 0 Then
If acK = "C" Then klasor = klasr3
If acK = "B" Then klasor = klasr2
If acK = "A" Then klasor = klasr1
klfl = klasor & "\" & acDos
ChDir klasor
Workbooks.Open Filename:=klfl, UpdateLinks:=0
End If
Windows(tmlD).Activate
Return

dosya_kapat:
Application.ScreenUpdating = True
ActiveWindow.WindowState = xlNormal
ActiveWorkbook.PrecisionAsDisplayed = True
Windows(tmlD).Activate
Return

renksiz:
With Selection.Interior
Selection.Interior.ColorIndex = xlNone
End With
Return

renkli:
With Selection.Interior
Selection.Interior.ColorIndex = 20
End With
Return

klasör_ara:
'directory will be checked for there is / is not ?
Dim ds, a
Set ds = CreateObject("Scripting.FileSystemObject")
a = ds.FolderExists(klasor)
If a <> True Then
MsgBox "Bu isimde bir klasör yok" & vbCrLf & "There is no directory named: " & klasor
End
End If
Return

Dosya_isimleri:
gel_say = gel_say + 1 'file names in directory will be listed
Sheets("PRM").Select
If gel_say <= 1 Then
Range("a11:IV" & Rows.Count).ClearContents
Range("a11:IV" & Rows.Count).Select
GoSub renksiz
End If
Dim dds, dc, f, s
Set dds = CreateObject("Scripting.FileSystemObject")
Set f = dds.GetFolder(klasor)
Set dc = f.Files
For Each dosya In dc
Sheets("PRM").Select
If gel_say = 1 Then hrf = "A10"
If gel_say = 2 Then hrf = "B10"
If gel_say = 3 Then hrf = "C10"
alan = hrf & ":" & Left(hrf, 1) & Rows.Count
rsay = Rows.Count - WorksheetFunction.CountBlank(Range(alan)) + 1
sn = dosya.Name
Cells(rsay, Left(hrf, 1)) = sn
Cells(rsay, Left(hrf, 1)).Select
GoSub hyprLink
Next
Return

hyprLink:
hLDs = klasor & "\" & sn
ActiveSheet.Hyperlinks.Add Anchor:=Selection, Address:=hLDs, SubAddress:=""
'Selection.Hyperlinks(1).Follow NewWindow:=False, AddHistory:=True
Return

acikD_check:
acDs = Application.Workbooks.Count
For ac = 1 To acDs
If Application.Workbooks(ac).Name = acDos Then
acikD = 1
Exit For
Else
acikD = 0
End If
Next ac
Return


Ds_varyok:
Set ds = CreateObject("Scripting.FileSystemObject")
a = ds.FolderExists(lnklsr) ' klasör varsa a = true
If a <> True Then
MsgBox "Bu isimde bir klasör yok" & vbCrLf & "There is no directory named: " & lnklsr
Else
Set dds = CreateObject("Scripting.FileSystemObject")
Set f = dds.GetFolder(lnklsr)
Set dc = f.Files
For Each dosya In dc
sn = dosya.Name
If sn = dosyaK Then
linkv = 1
Exit For
Else
linkv = 0
End If
Next
End If

Return

End Sub
 
Geri
Üst