Top-Themen

AppleEntwicklungHardwareInternetLinuxMicrosoftMultimediaNetzwerkeOff TopicSicherheitSonstige SystemeVirtualisierungWeiterbildungZusammenarbeit

Aktuelle Themen

Administrator.de FeedbackApache ServerAppleAssemblerAudioAusbildungAuslandBackupBasicBatch & ShellBenchmarksBibliotheken & ToolkitsBlogsCloud-DiensteClusterCMSCPU, RAM, MainboardsCSSC und C++DatenbankenDatenschutzDebianDigitiales FernsehenDNSDrucker und ScannerDSL, VDSLE-BooksE-BusinessE-MailEntwicklungErkennung und -AbwehrExchange ServerFestplatten, SSD, RaidFirewallFlatratesGoogle AndroidGrafikGrafikkarten & MonitoreGroupwareHardwareHosting & HousingHTMLHumor (lol)Hyper-VIconsIDE & EditorenInformationsdiensteInstallationInstant MessagingInternetInternet DomäneniOSISDN & AnaloganschlüsseiTunesJavaJavaScriptKiXtartKVMLAN, WAN, WirelessLinuxLinux DesktopLinux NetzwerkLinux ToolsLinux UserverwaltungLizenzierungMac OS XMicrosoftMicrosoft OfficeMikroTik RouterOSMonitoringMultimediaMultimedia & ZubehörNetzwerkeNetzwerkgrundlagenNetzwerkmanagementNetzwerkprotokolleNotebook & ZubehörNovell NetwareOff TopicOpenOffice, LibreOfficeOutlook & MailPapierkorbPascal und DelphiPeripheriegerätePerlPHPPythonRechtliche FragenRedHat, CentOS, FedoraRouter & RoutingSambaSAN, NAS, DASSchriftartenSchulung & TrainingSEOServerServer-HardwareSicherheitSicherheits-ToolsSicherheitsgrundlagenSolarisSonstige SystemeSoziale NetzwerkeSpeicherkartenStudentenjobs & PraktikumSuche ProjektpartnerSuseSwitche und HubsTipps & TricksTK-Netze & GeräteUbuntuUMTS, EDGE & GPRSUtilitiesVB for ApplicationsVerschlüsselung & ZertifikateVideo & StreamingViren und TrojanerVirtualisierungVisual StudioVmwareVoice over IPWebbrowserWebentwicklungWeiterbildungWindows 7Windows 8Windows 10Windows InstallationWindows MobileWindows NetzwerkWindows ServerWindows SystemdateienWindows ToolsWindows UpdateWindows UserverwaltungWindows VistaWindows XPXenserverXMLZusammenarbeit

Application.FileSearch in Office 2007?

Frage Microsoft Microsoft Office

Mitglied: Zockerman

Zockerman (Level 1) - Jetzt verbinden

11.11.2010 um 12:39 Uhr, 4482 Aufrufe, 1 Kommentar

Applikation.Filesearch ist in Office 2007 nicht mehr vorhanden. Daher suche ich nach einer passenden Alternative.

Hallo,

das folgende Programm, war dazu da, in unserer Firma, einen markierten Bereich in einer Exceltabelle durchzugehen und dann in einem vorher angegebenen Ordner, nach Dateien des selben Names zu suchen.
Ich hoffe ihr könnt mir helfen, da derjenige der das Makro geschrieben hat, nicht mehr hier ist und nun ich diese Aufgabe bekommen habe.

Mit freundlichen Grüßen
Christian Edel

P.S.: Hier das Makro:
Und schonmal VIELEN DANKE für die Hilfe!!!!



Sub VerknüpfungenErstellen_V3()
Dim pfad As String
'in welchem Verzeichnis liegen die Dokumente?
Dim oSh As Object
Dim oFd As Variant
Dim nS As Object

Set oSh = GetObject("", "Shell.Application")
Set oFd = oSh.BrowseforFolder(0, _
"Bitte ein Verzeichnis auswählen ...", 0, "")
Set nS = oFd.Self
pfad = nS.Path

Set oSh = Nothing


If pfad = "" Then Exit Sub

'Markierte Zellen durchgehen
For Each cell In Selection

gefunden = False



With Application.FileSearch
.NewSearch
.LookIn = pfad
.SearchSubFolders = True
.Filename = cell.Value & ".pdf"
.MatchTextExactly = True
.FileType = msoFileTypeAllFiles

If .Execute() > 0 Then
Select Case .FoundFiles.Count
Case 1
'Verknüpfen
'MsgBox "LINK: " & .FoundFiles(1)
ActiveSheet.Hyperlinks.Add cell, .FoundFiles(1)
gefunden = True
Case Else
MsgBox "Es wurde mehr ale eine passende Datei " & cell.Value & ".pdf gefunden. Bitte manuell verknüpfen."
End Select
Else
'MsgBox "Es wurde keine Datei " & cell.Value & ".pdf gefunden."
End If
End With

If Not (gefunden) Then
'mit verkürztem Suchstring (ohne führende Nullen) nochmal durchgehen, falls nichts gefunden wurde.
'Beispiel cell.Value = DE000004006420C5
' suchstring = DE4006420C5
suchstring = cell.Value
While Mid(suchstring, 3, 1) = "0" And Not (gefunden)

'eine Null entfernen..
suchstring = Left(suchstring, 2) & Right(suchstring, Len(suchstring) - 3)

'..und nochmal suchen
With Application.FileSearch
.NewSearch '
.LookIn = pfad
.SearchSubFolders = True
.Filename = suchstring & ".pdf"
.MatchTextExactly = True
.FileType = msoFileTypeAllFiles

If .Execute() > 0 Then
Select Case .FoundFiles.Count
Case 1
'Verknüpfen
'MsgBox "LINK: " & .FoundFiles(1)
ActiveSheet.Hyperlinks.Add cell, .FoundFiles(1)
gefunden = True
Case Else
MsgBox "Es wurde mehr ale eine passende Datei " & suchstring & ".pdf gefunden. Bitte manuell verknüpfen."
End Select
Else
MsgBox "Es wurde keine Datei " & suchstring & ".pdf gefunden."
End If
End With

Wend
End If

Next

End Sub
Mitglied: 76109
13.11.2010 um 13:55 Uhr
Hallo Christian!

Du könntest es mal mit diesem Code versuchen:
01.
Option Explicit 
02.
Option Compare Text 
03.
 
04.
Const Msg1 = "Es wurde mehr als eine passende Datei zu %1.pdf gefunden. Bitte manuell verknüpfen." 
05.
Const Msg2 = "Es wurde keine passende Datei zu %1.pdf gefunden." 
06.
 
07.
Dim Fso As Object, FileList As Object 
08.
 
09.
Sub SetHyperlinks() 
10.
    Dim Dlg As FileDialog, File As Variant, c As Range 
11.
    Dim Path As String, SearchName As String, FoundCount As Long 
12.
    
13.
    Set Dlg = Application.FileDialog(msoFileDialogFolderPicker) 
14.
     
15.
    Dlg.Title = "Verzeichnis auswählen..." 
16.
    Dlg.InitialFileName = "D:\Temp\"  'Start-Ordner 
17.
     
18.
    If Dlg.Show = False Then Exit Sub 
19.
     
20.
    Set Fso = CreateObject("Scripting.FileSystemObject") 
21.
    Set FileList = CreateObject("Scripting.Dictionary") 
22.
    
23.
    Call InitFileList(Fso.GetFolder(Dlg.SelectedItems(1))) 
24.
     
25.
    For Each c In Selection 
26.
        If Not IsEmpty(c) Then 
27.
            FoundCount = 0 
28.
             
29.
            For Each File In FileList.Items 
30.
                If c Like Fso.GetBaseName(File) Then 
31.
                    Path = File:  FoundCount = FoundCount + 1 
32.
                End If 
33.
            Next 
34.
             
35.
            If FoundCount = 0 Then 
36.
                SearchName = c 
37.
                 
38.
                Do While (Mid(SearchName, 3, 1) = "0") 
39.
                    SearchName = Left(c, 2) & Mid(SearchName, 4) 
40.
                     
41.
                    For Each File In FileList.Items 
42.
                        If Fso.GetBaseName(File) Like SearchName Then 
43.
                            Path = File:  FoundCount = FoundCount + 1 
44.
                        End If 
45.
                    Next 
46.
                Loop 
47.
            End If 
48.
                 
49.
            If FoundCount = 1 Then 
50.
                ActiveSheet.Hyperlinks.Add c, Path 
51.
            ElseIf FoundCount > 1 Then 
52.
                MsgBox Replace(Msg1, "%1", c), vbInformation, "Dateisuche..." 
53.
            Else 
54.
                MsgBox Replace(Msg2, "%1", c), vbInformation, "Dateisuche..." 
55.
            End If 
56.
        End If 
57.
    Next 
58.
End Sub 
59.
 
60.
Private Sub InitFileList(ByRef Folder) 
61.
    Dim File As Object, SubFolder As Object 
62.
     
63.
    For Each File In Folder.Files 
64.
        If LCase(Fso.GetExtensionName(File.Name)) = "pdf" Then 
65.
            FileList.Add FileList.Count + 1, File.Path 
66.
        End If 
67.
    Next 
68.
     
69.
    For Each SubFolder In Folder.SubFolders 
70.
        Call InitFileList(SubFolder) 
71.
    Next 
72.
End Sub
Gruß Dieter

PS Dein Code ließe sich in Code-Tags (siehe Formatierungshilfe) auch besser lesen
Bitte warten ..
Ähnliche Inhalte
Microsoft Office
gelöst Upgrade Office 2007 auf 2013 (3)

Frage von Lukas4580 zum Thema Microsoft Office ...

Microsoft Office
gelöst Office 2007 Upgrade auf 2013 ständiges First Run Fenster (5)

Frage von xbast1x zum Thema Microsoft Office ...

Windows Netzwerk
gelöst Dateiberechtigung Office 2007 und Office 2013 (3)

Frage von Maverick6 zum Thema Windows Netzwerk ...

Neue Wissensbeiträge
RedHat, CentOS, Fedora

Fedora, RedHat, Centos: DNS-Search Domain setzen

(13)

Tipp von Frank zum Thema RedHat, CentOS, Fedora ...

Drucker und Scanner

Samsung SL-M4025ND, firmware update und (kompatible) Tonerkassetten

(1)

Erfahrungsbericht von markus-1969 zum Thema Drucker und Scanner ...

Heiß diskutierte Inhalte
LAN, WAN, Wireless
gelöst Komplett neues Netzwerk, Ubiquiti WLAN, Router, Switch (16)

Frage von Freak-On-Silicon zum Thema LAN, WAN, Wireless ...

CMS
Lokales Wordpress im LAN - wie aufsetzen? (16)

Frage von Static zum Thema CMS ...

LAN, WAN, Wireless
IP im privaten Netz nicht erreichbar (14)

Frage von guntis zum Thema LAN, WAN, Wireless ...

LAN, WAN, Wireless
Devolo DLAN 500 pro Wireless+ (13)

Frage von IceAge zum Thema LAN, WAN, Wireless ...