Daten aus Word mit Layout/Excelsuche in Textfelder
Werner
Ich werde noch irre mit meiner Sache hier...
Ich habe eine Datei im Word-Format.
Die Daten aus der Datei kriege ich ja noch in Excel rein.
Aber dann stimmt ja in Sachen Layout nichts mehr.
Da es 160 Seiten sind ist das manuelle anpassen extrem zeitaufwendig.
Gibt es da nicht irgend einen Weg?
Ich würde ggf auch mit Textfeldern arbeiten.
Aber meine Excelsuche...
Sub finden()
' Startblatt merken, da hier nicht gesucht werden soll
Dim WshShell As Object
Application.ScreenUpdating = False
On Error Resume Next
Sheets("Suchergebnis").Select
mblatt = ActiveSheet.Name
Sheets("Hauptmenü").Select
msuch = Range("C5") 'Application.InputBox("Bitte den Suchtext eingeben", , Range("c5"))
If msuch = False Then
Exit Sub
End If
If Len(msuch) = 0 Then
MsgBox "Es muss schon ein Suchtext eingegeben werden"
Exit Sub
End If
' Alte gefundene Einträge löschen
Sheets("Suchergebnis").Select
Columns("A:B").Select
Selection.Clear
Cells(1, 1).Value = "Gefundene Einträge für die Suche nach: " + msuch
Cells(1, 2).Value = "Fundstelle"
' alte vergebene Namen löschen
z = 1
While z Sheets(i).Name Then
If Sheets(i).Visible Then
Worksheets(i).Select
If IsDate(msuch) Then
Set C = Cells.Find(DateValue(msuch), LookIn:=xlValues, Lookat:=xlPart)
Else
If IsNumeric(msuch) Then
Set C = Cells.Find(Val(msuch), LookIn:=xlValues, Lookat:=xlPart)
Else
Set C = Cells.Find(msuch, LookIn:=xlValues, Lookat:=xlPart)
End If
End If
If Not C Is Nothing Then
firstAddress = C.Address
Do
C.Select
' Name für gefundene Zelle vergeben (reiser1 ....)
ActiveWorkbook.Names.Add Name:="Suche" + Trim(Str(s)), RefersTo:="=" + _
Selection.Address
Sheets(mblatt).Cells(z, 1).Value = C.Value
Sheets(mblatt).Cells(z, 2).Value = Sheets(i).Name + "!" + C.Address
' Hyperlink eintragen in den Eintrag der gefundenen Stelle
Sheets(mblatt).Select
Cells(z, 1).Select
ActiveSheet.Hyperlinks.Add Anchor:=Selection, Address:="", SubAddress:= _
_
"Suche" + Trim(Str(s)), TextToDisplay:=C.text
s = s + 1
Sheets(i).Select
z = z + 1
Set C = Cells.FindNext(C)
Loop While Not C Is Nothing And C.Address firstAddress
End If
End If
End If
Next
Sheets("Hauptmenü").Select
Range("C5:F6").ClearContents
Suchergebnis.Show False
End Sub
sucht ja nicht in Textfeldern.Kann man das evtl. hinkriegen?
Danke für eure Hilfe!
Werner