Re: Inhalt aus Zelle anfügen
20.05.2003 20:36:31
Rolf St
Hallo Chris,
es funktioniert! Vielleicht kannst du ja noch was verbessern ?
So sieht das ganze Makro aus.Sub urkunde12042003()
' Urkunde Anhand der Startnummer drucken
Dim Suche As Variant
Dim Zeile As Long
Dim Spalte As Integer
Sheets("Urkunde").Select
Range("B14:C17,D17,C18,C19,C20,D21").ClearContents
Suche = Sheets("Urkunde").Cells(12, 10)
Application.ScreenUpdating = False
Worksheets("Ergebnisse").Activate
Cells(1, 1).Select
For Zeile = 1 To Cells.SpecialCells(xlLastCell).Row
If Sheets("Ergebnisse").Cells(Zeile, 3) = Suche Then
On Error Resume Next
Sheets("Urkunde").Range(Sheets("Urkunde").Range("K8")) = Sheets("Ergebnisse").Cells(Zeile, 12) & Sheets("Urkunde").Range("L8")
' Sheets("Urkunde").Cells(14, 2) = Sheets("Ergebnisse").Cells(Zeile, 12)
Sheets("Urkunde").Range(Sheets("Urkunde").Range("K3")) = Sheets("Ergebnisse").Cells(Zeile, 6) & Sheets("Urkunde").Range("L3")
'Sheets("Urkunde").Cells(17, 1) = Sheets("Ergebnisse").Cells(Zeile, 6)
Sheets("Urkunde").Range(Sheets("Urkunde").Range("K4")) = Sheets("Ergebnisse").Cells(Zeile, 5) & Sheets("Urkunde").Range("L4")
'Sheets("Urkunde").Cells(17, 2) = Sheets("Ergebnisse").Cells(Zeile, 5)
Sheets("Urkunde").Range(Sheets("Urkunde").Range("K5")) = Sheets("Ergebnisse").Cells(Zeile, 10) & Sheets("Urkunde").Range("L5")
'Sheets("Urkunde").Cells(18, 3) = Sheets("Ergebnisse").Cells(Zeile, 10)
Sheets("Urkunde").Range(Sheets("Urkunde").Range("K6")) = Sheets("Ergebnisse").Cells(Zeile, 1) & Sheets("Urkunde").Range("L6")
'Sheets("Urkunde").Cells(19, 3) = Sheets("Ergebnisse").Cells(Zeile, 1) & ". Platz Gesamtwertung"
Sheets("Urkunde").Range(Sheets("Urkunde").Range("K7")) = Sheets("Ergebnisse").Cells(Zeile, 2) & Sheets("Urkunde").Range("L7")
'Sheets("Urkunde").Cells(20, 3) = Sheets("Ergebnisse").Cells(Zeile, 2) & ". Platz in der Altersklasse"
Sheets("Urkunde").Range(Sheets("Urkunde").Range("K9")) = Sheets("Ergebnisse").Cells(Zeile, 4) & Sheets("Urkunde").Range("L9")
'Sheets("Urkunde").Cells(21, 4) = Sheets("Ergebnisse").Cells(Zeile, 4)
End If
Next Zeile
If IsEmpty(Sheets("Urkunde").Cells(21, 4)) Then
Sheets("Urkunde").Select
MsgBox "Startnummerdaten nicht vorhanden!"
Exit Sub
End If
Application.ScreenUpdating = True
Sheets("Urkunde").Select
Sheets("Urkunde").Cells(17, 3).Value = Cells(17, 1).Value & " " & Cells(17, 2).Value
Range("A17,B17").ClearContents
If Range("I1000").End(xlUp).Row + 1 < 20 Then
LetzteZeile = 20
Else
LetzteZeile = Range("I1000").End(xlUp).Row + 1
End If
'Wert übertragen
Cells(LetzteZeile, 9) = Range("J12")
Sheets("Urkunde").Select
ActiveSheet.PageSetup.PrintArea = "$A$13:$G$32"
ActiveWindow.SelectedSheets.PrintOut Copies:=1
Range("J12").Select
' ActiveSheet.PrintOut 'funktioniert in Office 97 nicht
End Sub
Tschüß
Rolf