hilfe, brauche makro 254 mal!

Moin an alle!
ich habe hier folgendes Makro mit dem Rekorder aufgezeichnet:


Sub blauf64dko1()
' blauf64dko1 Makro
' Makro am 13.07.2005 von densankau4711 aufgezeichnet
Range("BD3:BO3").Select
Selection.Copy
Sheets("Laufkarte").Select
Range("A1:L1").Select
ActiveSheet.Paste
Application.CutCopyMode = False
With Selection.Font
.Name = "Arial"
.Size = 26
.Strikethrough = False
.Superscript = False
.Subscript = False
.OutlineFont = False
.Shadow = False
.Underline = xlUnderlineStyleNone
.ColorIndex = xlAutomatic
End With
With Selection
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlBottom
.WrapText = False
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
End With
With Selection
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter
.WrapText = False
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
End With
Range("A1:L3").Select
Selection.Borders(xlDiagonalDown).LineStyle = xlNone
Selection.Borders(xlDiagonalUp).LineStyle = xlNone
With Selection.Borders(xlEdgeLeft)
.LineStyle = xlContinuous
.Weight = xlMedium
.ColorIndex = xlAutomatic
End With
With Selection.Borders(xlEdgeTop)
.LineStyle = xlContinuous
.Weight = xlMedium
.ColorIndex = xlAutomatic
End With
With Selection.Borders(xlEdgeBottom)
.LineStyle = xlContinuous
.Weight = xlMedium
.ColorIndex = xlAutomatic
End With
With Selection.Borders(xlEdgeRight)
.LineStyle = xlContinuous
.Weight = xlMedium
.ColorIndex = xlAutomatic
End With
ActiveWindow.SelectedSheets.PrintOut Copies:=1
Sheets("64-Doppel-KO").Select
Range("BR3").Select
With Selection.Interior
.ColorIndex = 15
.Pattern = xlSolid
End With
Range("BI4").Select
End Sub

Das ist makro1
beim 2ten makro soll dann aus ("BD3:BO3") ("BD4:BO4") werden,
aus BR3 soll BR4 werden & aus BI4 soll BI5 werden. usw. bei den nächsten makros.
Nur A1:L1 und A1:L3 soll immer so bleiben.
Muss ich nun wirklich alles 254x schreiben (oder kopieren und ändern),
oder giibt es da eine einfachere Möglichkeit?
Mit freundlichen Gruss, Dennis

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Hallo
ungetestet, aber probier mal
Option Explicit

Sub blauf64dko1()
Dim i As Long
Dim qWks As Worksheet, tWks As Worksheet
Dim tRng1 As Range, tRng2 As Range
'Von hier kommen die Daten
'Tabellennamen bitte anpassen
Set qWks = Worksheets("Tabelle1")
'Hier sollen die Daten hin
Set tWks = Worksheets("Laufkarte")
Set tRng1 = tWks.Range("A1:L1")
Set tRng2 = tWks.Range("A1:L3")
'Application.ScreenUpdating = False
For i = 3 To 257
    qWks.Range("BD" & i & ":BO" & i).Copy Destination:=tRng1
    Application.CutCopyMode = False
    With tRng1
        With .Font
            .Name = "Arial"
            .Size = 26
            .Underline = xlUnderlineStyleNone
            .ColorIndex = xlAutomatic
        End With
        .HorizontalAlignment = xlCenter
        .VerticalAlignment = xlCenter
        .WrapText = False
    End With
    With tRng2
        .Borders(xlDiagonalDown).LineStyle = xlNone
        .Borders(xlDiagonalUp).LineStyle = xlNone
        With .Borders(xlEdgeLeft)
            .LineStyle = xlContinuous
            .Weight = xlMedium
            .ColorIndex = xlAutomatic
        End With
        With .Borders(xlEdgeTop)
            .LineStyle = xlContinuous
            .Weight = xlMedium
            .ColorIndex = xlAutomatic
        End With
        With .Borders(xlEdgeBottom)
            .LineStyle = xlContinuous
            .Weight = xlMedium
            .ColorIndex = xlAutomatic
        End With
        With .Borders(xlEdgeRight)
            .LineStyle = xlContinuous
            .Weight = xlMedium
            .ColorIndex = xlAutomatic
        End With
    End With
    tWks.PrintOut Copies:=1
    With Sheets("64-Doppel-KO").Range("BR3").Interior
        .ColorIndex = 15
        .Pattern = xlSolid
    End With
Next i
Application.ScreenUpdating = True
End Sub
Gruss Rainer

Sub blauf64dko1( i as Long) Dim qWks As Worksheet, tWks As Worksheet Dim tRng1 As Range, tRng2 As Range 'Von hier kommen die Daten 'Tabellennamen bitte anpassen Set qWks = Worksheets("Tabelle1") 'Hier sollen die Daten hin Set tWks = Worksheets("Laufkarte") Set tRng1 = tWks.Range("A1:L1") Set tRng2 = tWks.Range("A1:L3") 'Application.ScreenUpdating = False qWks.Range("BD" & i & ":BO" & i).Copy Destination:=tRng1 Application.CutCopyMode = False With tRng1 With .Font .Name = "Arial" .Size = 26 .Underline = xlUnderlineStyleNone .ColorIndex = xlAutomatic End With .HorizontalAlignment = xlCenter .VerticalAlignment = xlCenter .WrapText = False End With With tRng2 .Borders(xlDiagonalDown).LineStyle = xlNone .Borders(xlDiagonalUp).LineStyle = xlNone With .Borders(xlEdgeLeft) .LineStyle = xlContinuous .Weight = xlMedium .ColorIndex = xlAutomatic End With With .Borders(xlEdgeTop) .LineStyle = xlContinuous .Weight = xlMedium .ColorIndex = xlAutomatic End With With .Borders(xlEdgeBottom) .LineStyle = xlContinuous .Weight = xlMedium .ColorIndex = xlAutomatic End With With .Borders(xlEdgeRight) .LineStyle = xlContinuous .Weight = xlMedium .ColorIndex = xlAutomatic End With End With tWks.PrintOut Copies:=1 With Sheets("64-Doppel-KO").Range("BR3").Interior .ColorIndex = 15 .Pattern = xlSolid End With Application.ScreenUpdating = True End Sub

Beliebteste Forumthreads (12 Monate)

4 Beiträge zum Forumthread Beiträge zu diesem Forumthread

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

4
Beiträge zum Forumthread

Beiträge zu diesem Forumthread