Makro ile dosya bulma ve açma

[enkin]

merhab arkadaslar. benim bir sorum olucaktı. herhangi bir klasör dizininde bir dosyayı buldurup açmak istiyorum.

Örneğin; 2012 isminde bir klasörüm var ve bu klasörün içinde 12 tane daha ayları içeren klasör var. ocak, şubat... gibi

Ben 2012 klasörünün içerisinde, A1 hücresinde yazılı olan excel dosyasını açtırmak istriyorum.


bu konuda bana yardımcı olabilecek bi arkadas varmıdı. şimdiden cok teşekkür ediorum hepinize

 

[Ömer]

Merhaba,

Sub Dosya_Ac()
 
    Dim ad As String, yol As String
 
    ad = Range("A1") & ".xls"
 
    [COLOR=red]yol = "D:\2012\"
[/COLOR]        
    CreateObject("Shell.Application").Open yol & ad
 
End Sub

Bu şekilde deneyin. yol parametresini kendinize göre düzenlersiniz.

.

 

[leumruk]

Merhaba,
Ömer Bey cevaplamış gerçi ama ben soruyu daha farklı anladım. Anladığım doğrultuda bir çalışma yaptım. Dosyayı klasörlerinizin bulunduğu klasörün içine kopyalayın ve çalıştırın ya da yol kısmına ana klasörünüzün adresini yazın.

Sub Dosya_Bul_Ac()
Set ds = CreateObject("Scripting.FileSystemObject")
yol = ThisWorkbook.Path
Dosya_Adi = [a1]
Application.ScreenUpdating = False
Do
Tekrar:
If ds.GetFolder(yol).subfolders.Count > 0 Then
    For Each kls In ds.GetFolder(yol).subfolders
        klslst = klslst & "{" & kls
    Next
End If
x = x + 1
deg = Split(klslst, "{")
yol = deg(x)
Dosya = Dir$(yol & "\" & Dosya_Adi & ".xl*")
Do While Dosya <> ""
Say = Say + 1
Workbooks.Open yol & "\" & Dosya
Exit Sub
Dosya = Dir$()
Loop
If x = 1 And ds.GetFolder(yol).subfolders.Count > 0 Then GoTo Tekrar
Loop While UBound(deg) <> x
'Kodlayan: l e u m r u k - mustafa altun
End Sub

 

[enkin]

arkadaslar cevaplarınız için tesekkur ederim. ömer beyin yazıdı kodlama bana pek uymuyor. mustafa bey yazdıgınız kodlama için tesekkur ederim bu benim işimi fazlasıyla görür.

 

[hukumran1]

Merhaba,

Sub Dosya_Ac()
 
    Dim ad As String, yol As String
 
    ad = Range("A1") & ".xls"
 
    [COLOR=red]yol = "D:\2012\"
[/COLOR]        
    CreateObject("Shell.Application").Open yol & ad
 
End Sub

Bu şekilde deneyin. yol parametresini kendinize göre düzenlersiniz.

.

Teşekkürler, çalıştırmayı başardım.

Ama ihtiyacım biraz daha farklı benim. Hücrelerde Ahmet, Hasan, Kemal vs vs gibi bir sürü isim var ve bu her isimin de bir fotoğrafı var pc de. Sürekli yeni isimler ekleniyor ve yeni fotoğraflar ekleniyor. Excelde her hücrenin içerdiği isimle fotoğrafına link oluşturuyorum. Tek tıklamayla fotoğraf bulunabiliyor böylece. (fotoğraf örnekti, evraklar ve evrak numaraları söz konusu olan) Benim amacım bu link verme olayını makroyla yapmak. a1 hücresinin içeriği ahmet, makromu çalıştırdığımda klasördeki ahmet isimli fotoğrafa ahmet hücresinden link atacak. Tabi sadece a1 hücresi değil örneğin a1 ile z1 arasına uygulamak isitiyorum. Hah birde daha önce link verilmiş olanları atlayacak tabi.

Umarım olmayacak şeyler istemiyorum.

 

[excelokyanus500]

Aşağıdaki kodları bir notepad açıp yapıştırın.
Kaydedin ve kapatın.
TXT olan uzantıyı vbs yapın.
Çift tıklayın.

Umarım işiniz görür.

' Declare Option Constants
Const BIF_EDITBOX = &H10
Const BIF_NONEWFOLDER = &H0200
Const BIF_RETURNONLYFSDIRS = &H1

Function Browse4Folder(strPrompt, intOptions, strRoot)
Dim objFolder, objFolderItem, objShell
Set objShell = CreateObject("Shell.Application")
Set objFolder = objShell.BrowseForFolder(0, strPrompt, intOptions, strRoot)
If (objFolder Is Nothing) Then
Browse4Folder = ""
Else
Set objFolderItem = objFolder.Self
Browse4Folder = objFolderItem.Path
Set objFolderItem = Nothing
Set objFolder = Nothing
End If
Set objShell = Nothing
End Function

strPrompt = "Please select the folder to process."
intOptions = BIF_RETURNONLYFSDIRS + BIF_EDITBOX + BIF_NONEWFOLDER

' Return the path, e.g. C:\
strFolderPath = Browse4Folder(strPrompt, intOptions, "")



Dim fso
Dim ObjOutFile
'Creating File System Object
Set fso = CreateObject("Scripting.FileSystemObject")
'Create an output file
Set ObjOutFile = fso.CreateTextFile("OutputFiles.csv")
'Writing CSV headers
ObjOutFile.WriteLine("Type,File Name,File Path")

'Call the GetFile function to get all files

'bakılacak yer

'GetFiles("D:\")
GetFiles(strFolderPath)

'Close the output file
ObjOutFile.Close

Function GetFiles(FolderName)
On Error Resume Next
Dim ObjFolder
Dim ObjSubFolders
Dim ObjSubFolder
Dim ObjFiles
Dim ObjFile
Set ObjFolder = fso.GetFolder(FolderName)
Set ObjFiles = ObjFolder.Files
'Write all files to output files
For Each ObjFile In ObjFiles
ObjOutFile.WriteLine("File," & ObjFile.Name & "," & ObjFile.Path)
Next
'Getting all subfolders
Set ObjSubFolders = ObjFolder.SubFolders
For Each ObjFolder In ObjSubFolders
'Writing SubFolder Name and Path
ObjOutFile.WriteLine("Folder," & ObjFolder.Name & "," & ObjFolder.Path)
'Getting all Files from subfolder
GetFiles(ObjFolder.Path)
Next
End Function


Dim objExcel
Dim objWorkBook
Set objShell = CreateObject("WScript.Shell")
userProfilePath = objShell.ExpandEnvironmentStrings("%UserProfile%")
strFileNamed =userProfilePath & "\Desktop\OutputFiles.csv"
strFileName =userProfilePath & "\Desktop\tested.xlsx"
'Instantiate Excel
Set objExcel = CreateObject("Excel.Application")
'open the CSV file
Set objWorkBook = objExcel.Workbooks.Open(strFileNamed)

'Save the file as excel workbook
objWorkBook.SaveAs (strFileName) , 51

'close workbook
objWorkBook.Close 'False
'quit excel
'objExcel.Quit

'clean up
'Set objWorkBook = Nothing
'Set objExcel = Nothing



on error resume next
Dim xlApp, xlBook
objExcel.Visible = True
objExcel.DisplayAlerts = False
Set objWorkbook = objExcel.Workbooks.Open(strFileName)
Set xlmodule = objworkbook.VBProject.VBComponents.Add(1)
strCode = _
"Sub ConvertToHyperlink()" & vbCr & _
"On error resume next" & vbCr & _
"Dim rng As Range" & vbCr & _
"Set rng = Range(""c1:c"" & Cells _" & vbCr & _
"(Rows.Count, 1).End(xlUp).Row)" & vbCr & _
"'Set rng = ActiveSheet.UsedRange" & vbCr & _
"For Each cell In rng" & vbCr & _
"cell.Select" & vbCr & _
"If cell.Value <> """" Then" & vbCr & _
"If Left(cell.Value, 7) = ""D:\"" Then" & vbCr & _
"URL = cell.Value" & vbCr & _
"Else" & vbCr & _
"URL = cell.Value '""http://"" +" & vbCr & _
"End If" & vbCr & _
"ActiveSheet.Hyperlinks.Add Anchor:=cell, _" & vbCr & _
"Address:=URL, TextToDisplay:=cell.Value" & vbCr & _
"End If" & vbCr & _
"Next" & vbCr & _
"End Sub"
On error resume next
xlmodule.CodeModule.AddFromString strCode
objExcel.Run "ConvertToHyperlink"
'xlApp.Run "borc"
xlBook.Close
xlApp.Quit
Set xlBook = Nothing
Set xlApp = Nothing

WScript.Echo "Dosya tamam"
objExcel.Application.DisplayAlerts=False
objWorkbook.SaveAs (strFileName)
'objExcel.Quit

WScript.Quit

 

[Uygur_26]

Merhaba,
Ömer Bey cevaplamış gerçi ama ben soruyu daha farklı anladım. Anladığım doğrultuda bir çalışma yaptım. Dosyayı klasörlerinizin bulunduğu klasörün içine kopyalayın ve çalıştırın ya da yol kısmına ana klasörünüzün adresini yazın.

Sub Dosya_Bul_Ac()
Set ds = CreateObject("Scripting.FileSystemObject")
yol = ThisWorkbook.Path
Dosya_Adi = [a1]
Application.ScreenUpdating = False
Do
Tekrar:
If ds.GetFolder(yol).subfolders.Count > 0 Then
    For Each kls In ds.GetFolder(yol).subfolders
        klslst = klslst & "{" & kls
    Next
End If
x = x + 1
deg = Split(klslst, "{")
yol = deg(x)
Dosya = Dir$(yol & "\" & Dosya_Adi & ".xl*")
Do While Dosya <> ""
Say = Say + 1
Workbooks.Open yol & "\" & Dosya
Exit Sub
Dosya = Dir$()
Loop
If x = 1 And ds.GetFolder(yol).subfolders.Count > 0 Then GoTo Tekrar
Loop While UBound(deg) <> x
'Kodlayan: l e u m r u k - mustafa altun
End Sub

Merhaba, farklı bir klasördeki excelleri açmak istersek "yol = ThisWorkbook.Path" yerine ne tanımlamak gerekiyor? Yardımcı olabilir misiniz?

 

[Korhan Ayhan]

Aşağıdaki gibi tanımlayabilirsiniz. Kendinize uyarlarsınız.

yol = "C:\Belgelerim"