AW: Excel VBA Word Kopfzeile auslesen
16.04.2016 07:06:55
fcs
Hallo Björn,
ich hab dir mal eine entsprechende Makrofunktion eingefügt.
Da die umbenennung von Tabellenblättern auch Fehler verursachen kan, hab ich dafür auch eine komplette Prüfung eingefügt. Da kannst du ggf. noch Anpassungen machen für zu lange Namen oder die Ersetzung von unzulässigen Zeichen.
Gruß
Franz
Sub WordtoExcel()
'---------------------------------------------------------------- Deklarationen
Dim Worddatei As Object
Dim stringtoFile As String
Dim anzahlSections As Integer, i As Integer
Dim section As Integer
Dim strName As String
Dim objWdApp As Object
'---------------------------------------------------------------- doc Datei öffnen
stringtoFile = Application.GetOpenFilename("Word Dateien (*.doc),*.doc")
If stringtoFile = "Falsch" Then
MsgBox "Falscher Dateityp"
Exit Sub
End If
'---------------------------------------------------------------- benötigte Tabellenblätter _
erstellen
Set Worddatei = GetObject(stringtoFile)
Set objWdApp = Worddatei.Application
objWdApp.Visible = True 'zum Testen später auf False setzen
anzahlSections = Worddatei.Sections.Count
For i = 1 To (anzahlSections - 1)
Sheets.Add After:=ActiveSheet
Next i
'---------------------------------------------------------------- Sections auslesen und in _
Tabelle einfügen
With Worddatei
For section = 1 To anzahlSections
strName = fncGetText_fromTextbox_in_Header(objWdSection:=.Sections(section))
.Sections(section).Range.Copy
Sheets(section).Select
Sheets(section).Range("A1").Activate
Sheets(section).Paste
Call fncSheetRename(objSheet:=Sheets(section), sNewName:=strName, _
strReplace:=" ", bolMsg:=True) 'Parameter bolMsg auf False setzen wenn _
alles funktioniert
Next section
.Close False
End With
objWdApp.Quit
Set Worddatei = Nothing
End Sub
Function fncGetText_fromHeader(objWdSection As Object) As String
'In Worddokument den Text in Kopzeile des Abschnitts auslesen
'objWdSection = Word.Section
Dim objWdHeader As Object 'Word.HeaderFooter
Set objWdHeader = objWdSection.Headers(1) ' 1 = wdHeaderFooterPrimary
fncGetText_fromHeader = objWdHeader.Range.Text
Set objWdHeader = Nothing
End Function
Function fncGetText_fromTextbox_in_Header(objWdSection As Object, _
Optional iItem As Integer = 1) As String
'In Worddokument den Text aus Shape in Kopfzeile auslesen
Dim objWdShape As Object 'Word.Shape
Dim objWdHeader As Object 'Word.HeaderFooter
Set objWdHeader = objWdSection.Headers(1) ' 1 = wdHeaderFooterPrimary
Set objWdShape = objWdHeader.Range.ShapeRange.Item(iItem)
fncGetText_fromTextbox_in_Header = objWdShape.TextFrame.TextRange.Text
MsgBox "Textbox in Kopfzeile Abschnitt " & objWdSection.Index & ": " _
& fncGetText_fromTextbox_in_Header 'testzeile
Set objWdHeader = Nothing
End Function
Public Function fncSheetRename(objSheet As Object, ByVal sNewName As String, _
Optional ByVal strReplace As String, _
Optional bolMsg As Boolean = False) As Boolean
Dim wkb As Workbook
Dim msgText As String, msgTitel As String
Dim objItem As Object
msgTitel = "B L A T T U M B E N E N N E N"
Set wkb = objSheet.Parent
'überzählige Leerzeichen am Anfag/Ende entfernen
sNewName = Trim(sNewName)
'Prüfung auf Leerstring
If Len(Trim(sNewName)) = 0 Then
fncSheetRename = False
msgText = "Leerstring bzw. nur Leerzeichen(Blamks) sind nicht zulässig als Blattnamen" _
_
& vbLf & "Blatt wird nicht umbenannt"
If bolMsg Then
MsgBox msgText, vbOKOnly, msgTitel
End If
GoTo Beenden
End If
'Prüfung auf länge Blattname
If Len(sNewName) > 31 Then
fncSheetRename = False
If bolMsg Then
msgText = "Der neue Blattname hat mehr als 31 Zeichen" _
& vbLf & "Blatt wird nicht umbenannt"
MsgBox msgText, vbOKOnly, msgTitel
End If
GoTo Beenden
End If
'Prüfung ob Blatt schon vorhanden
If fncSheetExists(sNewName, wkb) = True Then
fncSheetRename = False
If bolMsg Then
msgText = "Der neue Blattname ist schon vorhanden" _
& vbLf & "Blatt wird nicht umbenannt"
MsgBox msgText, vbOKOnly, msgTitel
End If
GoTo Beenden
End If
'Prüfung ob unzulässige/unerwünschte Zeichen im Blattnamen
If fncSheetZeichen(sNewName, varUnerwuenscht:=Array(""""), strReplace:=" ") = True Then
fncSheetRename = False
If bolMsg Then
msgText = "Der neue Blattname enthält unzuässige ('\ / : * ?) oder unerwünschte _
Zeichen" _
& vbLf & "Blatt wird nicht umbenannt"
MsgBox msgText, vbOKOnly, msgTitel
End If
GoTo Beenden
End If
objSheet.Name = sNewName
Beenden:
End Function
Public Function fncSheetExists(ByVal sSheetname As String, Optional wkb As Workbook) As Boolean
On Error GoTo Beenden
Dim objSheet As Object
If wkb Is Nothing Then Set wkb = ActiveWorkbook
Set objSheet = wkb.Sheets(sSheetname)
fncSheetExists = True
Beenden:
End Function
Public Function fncSheetZeichen(ByVal strName As String, Optional varUnerwuenscht, _
Optional ByVal strReplace As String)
Dim arrUnzulaessig As Variant, intZ As Integer
'unzulässige Zeichen in Blattnamen - Hochkomma ist als 1. Zeichen unzulässig
arrUnzulaessig = Array("'", "[", "/", "\", ":", "*", "?", "]")
fncSheetZeichen = False
For intZ = LBound(arrUnzulaessig) To UBound(arrUnzulaessig)
If InStr(1, strName, arrUnzulaessig(intZ)) > 0 Then
fncSheetZeichen = True
If strReplace "" Then strName = VBA.Replace(strName, arrUnzulaessig(intZ), _
strReplace)
End If
Next
If Not IsMissing(varUnerwuenscht) Then
For intZ = LBound(varUnerwuenscht) To UBound(varUnerwuenscht)
If InStr(1, strName, varUnerwuenscht(intZ)) > 0 Then
fncSheetZeichen = True
If strReplace "" Then strName = VBA.Replace(strName, varUnerwuenscht(intZ), _
strReplace)
End If
Next
End If
If strReplace "" Then fncSheetZeichen = False
End Function