Hücredeki değeri klasör içinde arama

[cuneytergul]

Merhabalar
Benzer konular var fakat benim ki biraz farklı olduğu için konu açmak durumunda kaldım
C stunundaki formulun bana vermiş olduğu değeri belirlediğim klasör içinde aratarak F stununda bağlantısını oluşturmak istiyorum.Fakat c stunundaki değerin karşılığı olan dosya isminde önünde ve arkasında başka şeyler yazıyor.

Örnek olarak c stununda 180031111 yazıyor. Dosyası : [4000011111 PIERRET INDUSTRIES S.P.R.L. İŞ EMRİ 180031111]
dosya ismi içeriği 180031111 olan dosyanın bağlantısını F stununda oluşturmasını istiyorum.

Hatta olabilirse dosya ismi içeriği 180031111 olan birden fazla dosya varsa.G,H,I... stunlarına dosya bağlatısını yazsın

Yardımlarınız için şimdiden teşekkürler

 

[cuneytergul]

@Korhan Ayhan Abi yardımcı olabilir misin. İş yerinde çok fazla ihtiyaç duyuyorum

 

[Korhan Ayhan]

Forumda örnekler var. Arama yaparsanız örneklere ulaşabilirsiniz.

Arama yapacağınız ifadeler

While-Wend-Dir-Hyperlinks.Add

 

[cuneytergul]

Düşey arama yaparak bu şekilde istediğime ulaşıcam


Elimdeki kod ile bir klasör belirleyip bu klasördeki dosyaları otmatik güncellemesini sağlayabilir miyim, yani her defasında klasör seçmek istemiyorum ve bu listenin sürekli güncellenmesini bekliyorum.

Hedef klasör: C:\Users\cergul\CUNEYT DOSYALAR\FİKTİF\itahaller


Bulduğum kod bu:

Sub listfiles()
'Updateby Extendoffice
Dim xFSO As Object
Dim xFolder As Object
Dim xFile As Object
Dim xFiDialog As FileDialog
Dim xPath As String
Dim I As Integer
Set xFiDialog = Application.FileDialog(msoFileDialogFolderPicker)
If xFiDialog.Show = -1 Then
xPath = xFiDialog.SelectedItems(1)
End If
Set xFiDialog = Nothing
If xPath = "" Then Exit Sub
Set xFSO = CreateObject("Scripting.FileSystemObject")
Set xFolder = xFSO.GetFolder(xPath)
For Each xFile In xFolder.Files
I = I + 1
ActiveSheet.Hyperlinks.Add Cells(I, 1), xFile.Path, , , xFile.Name
Next
End Sub

 

[Korhan Ayhan]

Biraz kurcalayın derim..

 

[cuneytergul]

xpath ı kaldırıp, set xfolder = dosya konumu nu yazdım

Kodlamadan anlamıyorum rica ediyorum yardım etseniz

 

[Korhan Ayhan]

Deneyiniz.

Kod içinde yazan File_Path = "C:\Users\Desktop\Deneme\" dosya yolunu kendinize göre revize edersiniz.

Option Explicit

Sub Search_For_Code_In_Name_Of_Files_In_Folder()
    Dim File_Path As String, My_File As String
    Dim Rng As Range, Last_Column As Integer
    Dim Process_Time As Double
    
    Process_Time = Timer
    
    Application.ScreenUpdating = False
    
    File_Path = "C:\Users\Desktop\Deneme\"
    
    Range("F:XFD").Clear
    
    For Each Rng In Range("C1:C" & Cells(Rows.Count, "C").End(3).Row)
        Last_Column = 6
        If Rng.Value <> "" Then
            My_File = Dir(File_Path & "*" & Rng.Value & "*")
            While My_File <> ""
                Cells(Rng.Row, Last_Column) = My_File
                ActiveSheet.Hyperlinks.Add Anchor:=Cells(Rng.Row, Last_Column), Address:=File_Path & My_File
                Last_Column = Last_Column + 1
                My_File = Dir
            Wend
        End If
    Next
    
    Application.ScreenUpdating = True
    
    MsgBox "İşleminiz tamamlanmıştır." & vbCrLf & vbCrLf & _
           "İşlem süresi ; " & Format(Timer - Process_Time, "0.00") & " Saniye", vbInformation
End Sub

 

[cuneytergul]

Deneyiniz.

Kod içinde yazan File_Path = "C:\Users\Desktop\Deneme\" dosya yolunu kendinize göre revize edersiniz.

Option Explicit

Sub Search_For_Code_In_Name_Of_Files_In_Folder()
    Dim File_Path As String, My_File As String
    Dim Rng As Range, Last_Column As Integer
    Dim Process_Time As Double
  
    Process_Time = Timer
  
    Application.ScreenUpdating = False
  
    File_Path = "C:\Users\Desktop\Deneme\"
  
    Range("F:XFD").Clear
  
    For Each Rng In Range("C1:C" & Cells(Rows.Count, "C").End(3).Row)
        Last_Column = 6
        If Rng.Value <> "" Then
            My_File = Dir(File_Path & "*" & Rng.Value & "*")
            While My_File <> ""
                Cells(Rng.Row, Last_Column) = My_File
                ActiveSheet.Hyperlinks.Add Anchor:=Cells(Rng.Row, Last_Column), Address:=File_Path & My_File
                Last_Column = Last_Column + 1
                My_File = Dir
            Wend
        End If
    Next
  
    Application.ScreenUpdating = True
  
    MsgBox "İşleminiz tamamlanmıştır." & vbCrLf & vbCrLf & _
           "İşlem süresi ; " & Format(Timer - Process_Time, "0.00") & " Saniye", vbInformation
End Sub

çok teşekkür ederim