Makro verkleinern ?

Hallo Leute!
Kann man das folgende Makro noch irgendwie aufkürzen?
Habe es mit dem Makrorekorder erstellt.

Option Explicit

Private Sub ZahlenTransponieren()
Application.ScreenUpdating = False
Range("A13") = 1
Range("A14") = 2
Range("A13:A14").AutoFill Destination:=Range("A13:A50"), Type:=xlFillDefault
Range("A1:A3").NumberFormat = "00"
'   Lfd.Nr.01-38
Range("A1:G1").Copy
Range("B13").PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _
False, Transpose:=True
Range("A2:G2").Copy
Range("B20").PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _
False, Transpose:=True
Range("A3:G3").Copy
Range("B27").PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _
False, Transpose:=True
Range("A4:G4").Copy
Range("B34").PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _
False, Transpose:=True
Range("A5:G5").Copy
Range("B41").PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _
False, Transpose:=True
Range("A6:C6").Copy
Range("B48").PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _
False, Transpose:=True
Range("D13") = 39
Range("D14") = 40
Range("D13:D14").AutoFill Destination:=Range("D13:D50"), Type:=xlFillDefault
Range("A1:A3").NumberFormat = "00"
'Lfd.Nr.39-76
Range("D6:G6").Copy
Range("E13").PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _
False, Transpose:=True
Range("A7:G7").Copy
Range("E17").PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _
False, Transpose:=True
Range("A8:G8").Copy
Range("E24").PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _
False, Transpose:=True
Range("A9:G9").Copy
Range("E31").PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _
False, Transpose:=True
Range("A10:G10").Select
Range("E38").PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _
False, Transpose:=True
Range("A11:F11").Copy
Range("E45").PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _
False, Transpose:=True
Application.CutCopyMode = False
Range("A1").Select
Application.ScreenUpdating = True
End Sub

Einstweilen herzlichen Dank an alle, die sich für mich bemühen.
MfG
Odje

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Benutzer

Private Sub ZahlenTransponieren_neu() Dim i As Byte Application.ScreenUpdating = False Range("A13") = 1 Range("A13:A50").DataSeries Step:=1 Range("D13") = 39 Range("D13:D50").DataSeries Step:=1 Range("A1:A3").NumberFormat = "00" For i = 1 To 11 Range("A" & i).Resize(, 7).Copy If i > 6 Then Range("E" & (i - 6) * 7 + 6).PasteSpecial Transpose:=True Else Range("B" & i * 7 + 6).PasteSpecial Transpose:=True End If Next i Application.CutCopyMode = False Application.ScreenUpdating = True End Sub

Private Sub ZahlenTransponieren_neu() Dim i As Byte Application.ScreenUpdating = False Range("A13") = 1 Range("A13:A50").DataSeries Step:=1 Range("D13") = 39 Range("D13:D50").DataSeries Step:=1 Range("A1:A3").NumberFormat = "00" For i = 1 To 11 Range("A" & i).Resize(, IIf(i = 6, 3, 7)).Copy If i > 6 Then Range("E" & (i - 6) * 7 + 9).PasteSpecial Transpose:=True Else Range("B" & i * 7 + 6).PasteSpecial Transpose:=True End If Range("D6:G6").Copy Range("E13").PasteSpecial Transpose:=True Next i Application.CutCopyMode = False Application.ScreenUpdating = True End Sub

Sub tt() Dim i As Integer Application.ScreenUpdating = False For i = 1 To 38 Cells(i + 12, 1) = i Cells(i + 12, 2) = Range("A1:G11").Cells(i) Cells(i + 12, 4) = i + 38 Cells(i + 12, 5) = Range("A1:G11").Cells(i + 38) Next Application.ScreenUpdating = True End Sub

Sub umformen() Range("A13:A50,D13:D50").FormulaR1C1 = "=Row()-12+38*Rounddown(Column()/3,0)" Range("B13:B50,E13:E50").FormulaR1C1 = "=INDEX(R1C1:R11C7,ROUNDUP(RC[-1]/7,0),MOD(RC[-1]-1,7)+1) _ Range("A13:E50").Formula = Range("A13:E50").Value End Sub

Beliebteste Forumthreads (12 Monate)

8 Beiträge zum Forumthread Beiträge zu diesem Forumthread

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

8
Beiträge zum Forumthread

Beiträge zu diesem Forumthread