Ağdaki dosyadan istenileni bulma

[CaSpi]

Arkadaşlar ben aradım fomrda örneği bulamadım. Ağdaki (\\FileServer\Excel\) Excel klasörü içerisinde xls uzantılı 1,2,3....2000 adlı kayıtlar bulunmakta. Bunu ana bir excel fayılından bir buton ve textbox kullanarak nasıl bulacağıma ait elinde örnek bir uygulama veya kodları olan varmı acaba?

Teşekkürler.

 

[halit3]

bu kodu denermisiniz.

Dim Klasor As Object
Dim Obj As Object
Dim Kaynak As String
Dim baslangıc As String

Sub bul()
a = MsgBox("Sayfayı temizlemek istiyormusunuz ", vbYesNo + vbInformation, c & " Rapor aktarımı")
If a = vbYes Then
ThisWorkbook.Sheets(ActiveSheet.Name).Columns("A:FT").ClearContents
ThisWorkbook.Sheets(ActiveSheet.Name).Columns("A:A").Hyperlinks.Delete
ThisWorkbook.Sheets(ActiveSheet.Name).Columns("A:A").Font.Underline = xlUnderlineStyleNone
Rows("1:" & Rows.Count).Interior.ColorIndex = xlNone
End If
Columns("A:A").ColumnWidth = 8.43
sat1 = Cells(Rows.Count, "A").End(3).Row - 1
On Error Resume Next
Kaynak = "\\FileServer\Excel" ' buraya ağdaki veri alacağın adresi yazacaksınız.
baslangıc = InputBox("Veri Alınacak Başlangıç satırı yazınız.", "Veri Alınacak Başlangıç satır no", "xls", 400, 30)
If baslangıc = "" Then
MsgBox "İşlemi iptal ettiniz"
Exit Sub
End If
Call Liste(Kaynak, "")
Application.DisplayAlerts = False
Columns("C:C").Select
Columns("B:B").TextToColumns Destination:=Range("C1"), DataType:=xlDelimited, _
TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=True, _
Semicolon:=False, Comma:=False, Space:=False, Other:=True, OtherChar _
:="\", FieldInfo:=Array(Array(2, 2))
Columns("A:A").EntireColumn.AutoFit
Range("A1").Select
sat = Cells(Rows.Count, "A").End(3).Row - 1
MsgBox sat - sat1 & " adet dosya bulundu işlem tamam"
End Sub

Private Sub Liste(Klasor As String, Uzanti As String)
Dim fL As Object, f As Object, Dosya As String, j As Long
Set fL = CreateObject("Scripting.FileSystemObject").getfolder(Klasor).SubFolders
Dim wb As Workbook
Uzanti = baslangıc
Dosya = Dir(Klasor & "\*.**" & Uzanti)
Application.ScreenUpdating = False
While Dosya <> ""
DoEvents
Application.DisplayAlerts = False
If ThisWorkbook.Name <> Dosya Then
On Error Resume Next
sat = [a65000].End(3).Row + 1
sat = Cells(Rows.Count, "A").End(3).Row + 1
Cells(sat, 1).Hyperlinks.Add Anchor:=Cells(sat, 1), Address:=Klasor & "\" & Dosya, TextToDisplay:=Dosya
Cells(sat, "B").Value = Klasor & "\" & Dosya
End If
Dosya = Dir
Wend
On Error GoTo sonraki
For Each f In fL
Kaynak = f.path
'Liste (f.path)
Call Liste(Kaynak, "")
sonraki:
Next
Set fL = Nothing
End Sub

 

[halit3]

ayrıca aşağıdaki linkdeki dosyaya bir bakınız.

http://www.excel.web.tr/showthread.php?t=83975

 

[CaSpi]

Halit bey çok teşekkür ederim. Kodları inceledim ama kendime bir türlü uygulayamadım. Benim istediyim textboxta adını yazdığım exelin yani ağda olan excel klasörü içerisinde 3,4,20..... adlı excelli bulmak ve otoamatik açılması.

İlginiz için teşekkürler.

 

[halit3]

Halit bey çok teşekkür ederim. Kodları inceledim ama kendime bir türlü uygulayamadım. Benim istediyim textboxta adını yazdığım exelin yani ağda olan excel klasörü içerisinde 3,4,20..... adlı excelli bulmak ve otoamatik açılması.

İlginiz için teşekkürler.

2 nolu mesajdaki kodları yeniden derledim. kontrol ediniz.