AW: Zelleninhalte in Textfile speichern
09.09.2003 06:56:04
Willie
Hallo Stefan
Leider habe ich erst jetzt gesehen, das du Kaum VBA-kenntnisse hast. Leider habe ich
jetzt auch nicht so viel Zeit. Aber hier mal ein Anregung. Es wird Word geöffnet
und die Daten aus Tabelle1 Zeile (ein paar werden übertragen!) Versuchs mal du kannst
dich auch nochmal im Forum melden... dann kann ich später nochmal helfen!
Gruß
Willie
Sub ExcelTabelleNachWordZwischenablage()
Dim WordObj As Object
Dim WordDoc As Object
Dim i As Integer
x = Application.Version
x = Left(x, 1)
If x = 1 Then
x = 10
End If
Sheets("Tabelle1").Select
iEnde = ActiveSheet.UsedRange.Rows.Count
Suche = 1
Do Until Suche = iEnde
Vergleich = Trim(Cells(Suche, 26).Value)
If Vergleich = "Summe:" Then
i = Suche
Suche = iEnde - 1
End If
Suche = Suche + 1
Loop
Columns("AA:AA").Select
Selection.NumberFormat = "#,##0.00 $"
Range("X1:AA1").Select
Selection.Borders(xlDiagonalDown).LineStyle = xlNone
Selection.Borders(xlDiagonalUp).LineStyle = xlNone
With Selection.Borders(xlEdgeLeft)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
With Selection.Borders(xlEdgeTop)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
With Selection.Borders(xlEdgeBottom)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
With Selection.Borders(xlEdgeRight)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
With Selection.Borders(xlInsideVertical)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
On Error Resume Next
Range("X2:AA" & Suche).Select
If Err.Number = 1004 Then
MsgBox "Es muß mindestes 1 Wert eingegeben sein!", vbInformation, "Eingabe bitte wiederholen!"
Exit Sub
End If
With Selection
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlBottom
.WrapText = False
.Orientation = 0
.AddIndent = False
.ShrinkToFit = False
.MergeCells = False
End With
Columns("AA:AA").Select
With Selection
.HorizontalAlignment = xlGeneral
.VerticalAlignment = xlBottom
.WrapText = False
.Orientation = 0
.ShrinkToFit = False
.MergeCells = False
End With
On Error Resume Next
Set WordObj = GetObject(, "word.application." & x & "")
If Err.Number = 429 Then
Set WordObj = CreateObject("word.application." & x & "")
Err.Number = 0
End If
WordObj.Visible = True ' Ab hier wird es für dich interessant!
Set WordDoc = WordObj.documents.Add
With WordObj.Selection
.Font.Name = "Courier New"
.Font.Bold = True
.typetext Text:="Absender: " & " " & Date
.TypeParagraph
.typetext Text:=Cells(1, 1).Value & " -"
.TypeParagraph
.typetext Text:=Cells(1, 2).Value & " -"
.TypeParagraph
.typetext Text:=Cells(1, 4).Value & " -"
.TypeParagraph
.typetext Text:=Cells(1, 5).Value & " -"
.TypeParagraph
.TypeParagraph
.TypeParagraph
.typetext Text:="An "
.TypeParagraph
.typetext Text:=Cells(1, 6).Value
End With
End Sub