'******************************************************************************
Public Sub NamenTabelle2SpaltigIn1Spaltig()
' 1.spalte 2.spalte
'
'müller bernd
'müller bruno
'müller marion
'
'schmidt andrea
'schmidt ivonne
'schmidt markus
'
'und so soll es aussehen:
'
'müller
' bernd
' bruno
' marion
'
'schmidt
' andrea
' ivonne
' markus
'Output:
' In einem neuen Document wird eine einspaltige Tabelle angelegt
' Namen, Vornamen werden nach obigem Muster ausgerichtet
'******************************************************************************
->Spaltendefinition
Const c_SPName = 1
Const c_SPVorname = 2
->Formatangaben der Ausgabe-Tabelle
Const c_Tab2_Width = 5->Breite in cm
Const c_Tab2_Einzug = 0.5->Einzug bei Vornamen
Dim doc1 As Document, tab1 As Table, doc2 As Document, tab2 As Table
Dim s_Name As String, s_lastName As String, s_Vorname As String
Dim z1 As Long, z2 As Long, l_EinzugPoints As Long
l_EinzugPoints = CentimetersToPoints(c_Tab2_Einzug)
Set doc1 = ActiveDocument
->1. schauen, ob Selection in einer Tabelle steht
If Not PruefenEineTabelleSelektiert Then GoTo Aufraeumen
Set tab1 = Selection.Tables(1)
->2. Spaltenanzahl 2 prüfen
If Not PruefenTabelleSpaltenAnzahl(tab1, 2) Then GoTo Aufraeumen
->3. neues Document anlegen
Documents.Add
Set doc2 = ActiveDocument
->4. Tabelle einfügen
doc2.Tables.Add Range:=Selection.Range, NumRows:=1, NumColumns:=1
Set tab2 = doc2.Tables(1)
->5. Tabelle formatieren
With tab2.Columns(1)
.SetWidth _
ColumnWidth:=CentimetersToPoints(c_Tab2_Width), _
RulerStyle:=wdAdjustFirstColumn
End With
With tab2.Rows
.Alignment = wdAlignRowLeft:
.AllowBreakAcrossPages = True
End With
->Tabelle abarbeiten
s_lastName = xxxxxxxxxxxxxxxxxxxx
z2 = 0
For z1 = 1 To tab1.Rows.Count
->aktuelle Zeile Ziel-Tabelle hochzählen
z2 = z2 + 1
->Zeile in Zieltabelle einfügen
tab2.Rows(z2).Select
Selection.InsertRows 1
->Namen aus Quell-Tabelle
s_Name = tab1.Cell(Row:=z1, Column:=c_SPName).Range.Text
->ggf. anhängende Leerzeichen und Steuerzeichen abschneiden
Call AnhaengendeSteuerUndLeerzeichenAbschneiden(s_Name)
->Vorname aus Quell-Tabelle
s_Vorname = tab1.Cell(Row:=z1, Column:=c_SPVorname).Range.Text
->ggf. anhängende Leerzeichen und Steuerzeichen abschneiden
Call AnhaengendeSteuerUndLeerzeichenAbschneiden(s_Vorname)
If s_Name = Then
->Leerzeile -> nur Einzug
tab2.Rows(z2).SetLeftIndent _
LeftIndent:=l_EinzugPoints, _
RulerStyle:=wdAdjustFirstColumn
ElseIf s_Name = s_lastName Then
->Name wie Vorgänger -> Einzug und Vornamen eintragen
tab2.Rows(z2).SetLeftIndent _
LeftIndent:=l_EinzugPoints, _
RulerStyle:=wdAdjustFirstColumn
tab2.Cell(Row:=z2, Column:=1).Range.Text = s_Vorname
Else
->neuer Name
->kein Einzug, Namen eintragen
tab2.Rows(z2).SetLeftIndent _
LeftIndent:=0, _
RulerStyle:=wdAdjustFirstColumn
tab2.Cell(Row:=z2, Column:=1).Range.Text = s_Name
->Namen für nächste Vergleiche merken
s_lastName = s_Name
->weitere Zeile mit Einzug und Vornamen eintragen
z2 = z2 + 1
tab2.Rows(z2).Select
Selection.InsertRows 1
tab2.Rows(z2).SetLeftIndent _
LeftIndent:=l_EinzugPoints, _
RulerStyle:=wdAdjustFirstColumn
tab2.Cell(Row:=z2, Column:=1).Range.Text = s_Vorname
End If
Next z1
->letzte Zeile löschen
tab2.Rows(tab2.Rows.Count).Delete
->Cursor in erste Tabellen-Spalte setzen
tab2.Rows(1).Select
Selection.Collapse
Aufraeumen:
Set doc1 = Nothing: Set doc2 = Nothing: Set tab1 = Nothing: Set tab2 = Nothing
End Sub
'******************************************************************************
Private Function PruefenTabelleSpaltenAnzahl( _
mytab As Table, _
l_anzCol As Long) As Boolean
->Spaltenanzahl der Tabelle prüfen
If mytab.Columns.Count <> l_anzCol Then
MsgBox ( _
Die Tabelle hat & mytab.Columns.Count & Spalten. & vbCrLf & _
Erwartet wird eine Tabelle mit & l_anzCol & Spalten.)
PruefenTabelleSpaltenAnzahl = False
Else
PruefenTabelleSpaltenAnzahl = True
End If
End Function
'******************************************************************************
Private Function AnhaengendeSteuerUndLeerzeichenAbschneiden(s_Str As String)
->ggf. anhängende Leerzeichen und Steuerzeichen abschneiden
Dim s As String
Do
s = Right(s_Str, 1)
Select Case s
Case Chr(0) To Chr(32): s_Str = Left(s_Str, Len(s_Str) - 1)
Case Else: Exit Do
End Select
Loop
End Function
'******************************************************************************
Private Function PruefenEineTabelleSelektiert() As Boolean
->1. schauen, ob Selection in einer Tabelle steht
If Selection.Tables.Count <> 1 Then
If Selection.Tables.Count = 0 Then
MsgBox ( _
Der Cursor steht nicht in einer Tabelle. & vbCrLf & _
Bitte setzen Sie den Cursor in die Namen-Tabelle.)
Else
MsgBox ( _
In der Selection sind & Selection.Tables.Count & _
Tabellen selektiert. & vbCrLf & _
Bitte setzen Sie den Cursor in eine Namen-Tabelle.)
End If
PruefenEineTabelleSelektiert = False
Else
PruefenEineTabelleSelektiert = True
End If
End Function
