Top-Themen

Aktuelle Themen (A bis Z)

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, 4539 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
Windows Netzwerk
Dateiberechtigung Office 2007 und Office 2013
gelöst Frage von Maverick6Windows Netzwerk3 Kommentare

Hallo zusammen, ich habe bei mir ein Phänomen, welches ich mir nicht erklären kann. Auf einem Netzlaufwerk soll eine ...

Microsoft Office
Speicherpfade in Office 2007 ändern!
gelöst Frage von mike7050Microsoft Office2 Kommentare

Hallo, wie ich bei Office die Speicherpfade ändern kann weis ich aber wie kann ich es verhindern, dass wenn ...

Microsoft Office
Office 2007 Aktivierungsfehler
Frage von 118534Microsoft Office5 Kommentare

Hallo, ich habe mein Office 2007 jetz auf Englisch gedownloaded und installiert. Bei der aktivierung habe ich den Key ...

Microsoft Office
Office 2007 neuinstallieren
gelöst Frage von tomolpiMicrosoft Office25 Kommentare

Hallo Leute, ich habe neulich ein altes Notebook bei uns gefunden. Das hatte noch ein XP und ein installiertes ...

Neue Wissensbeiträge
Windows 10

Autsch: Microsoft bündelt Windows 10 mit unsicherer Passwort-Manager-App

Tipp von kgborn vor 1 TagWindows 103 Kommentare

Unter Microsofts Windows 10 haben Endbenutzer keine Kontrolle mehr, was Microsoft an Apps auf dem Betriebssystem installiert (die Windows ...

Sicherheits-Tools

Achtung: Sicherheitslücke im FortiClient VPN-Client

Tipp von kgborn vor 1 TagSicherheits-Tools

Ich weiß nicht, wie häufig die NextGeneration Endpoint Protection-Lösung von Fortinet in deutschen Unternehmen eingesetzt wird. An dieser Stelle ...

Internet

USA: Die FCC schaff die Netzneutralität ab

Information von Frank vor 1 TagInternet5 Kommentare

Jetzt beschädigt US-Präsident Donald Trump auch noch das Internet. Der neu eingesetzte FCC-Chef Ajit Pai ist bekannter Gegner einer ...

DSL, VDSL

ALL-BM200VDSL2V - Neues VDSL-Modem mit Vectoring von Allnet

Information von Lochkartenstanzer vor 1 TagDSL, VDSL2 Kommentare

Moin, Falls jemand eine Alternative zu dem draytek sucht: Gruß lks

Heiß diskutierte Inhalte
Windows Server
GPO nur für bestimmte Computer
Frage von Leo-leWindows Server13 Kommentare

Hallo Forum, gern würde ich ein Robocopy script per Bat an eine GPO hängen. Wichtig wäre aber dort der ...

Windows Server
KMS Facts for Client configuration
Frage von winlinWindows Server13 Kommentare

Hey Leute, wir haben in unserem Netz nun einen neuen KMS Server. Haben Bestands-VMs die noch nicht aktiviert sind. ...

Router & Routing
OpenWRT bzw. L.E.D.E auf Buffalo WZR-HP-AG300H - update
gelöst Frage von EpigeneseRouter & Routing11 Kommentare

Guten Tag, ich habe auf einem Buffalo WZR-HP-AG300H die alternative Firmware vom L.E.D.E Projekt geflasht. Ich bin es von ...

Windows Tools
Software-Tool zum Entfernen von bösartigem Windows
Frage von emeriksWindows Tools11 Kommentare

Hi, siehe Betreff hat das jemals irgendjemand schonmal sinnvoll eingesetzt? (MRT) E.