Makro verbessern

Forumthread: Makro verbessern

Makro verbessern

02.03.2020 00:02:07

Kisska

Hallo allerseits,
ich verwende dieses Makro um zwei Bereiche ohne Leerzellen zu transponieren:

Sub TransponierenOhneLeerzellen()
'Nr 1
With ActiveSheet
.Range("H2:H27").Copy
.Range("K1").PasteSpecial Paste:=xlValues, Transpose:=True
.Range("K1:AJ1").SpecialCells(xlCellTypeBlanks).Delete shift:=xlToLeft
End With
'Nr 2
With ActiveSheet
.Range("H28:H53").Copy
.Range("K2").PasteSpecial Paste:=xlValues, Transpose:=True
.Range("K2:AJ2").SpecialCells(xlCellTypeBlanks).Delete shift:=xlToLeft
End With
End Sub

Leider bekomme ich ein Laufzeitfehler, da ich in der Spalte H keine echten leeren Zellen habe. Die Leerzellen werden durch eine Wenn-Dann-Formel als "" erzeugt.
Frage 1: Wie kann man das Makro dennoch zum Laufen bringen?
Frage 2: Ich möchte, dass alle Zellinhalte ab der Spalte K geleert werden, bevor das eigentliche Makro beginnt. M.a.W. wie lasse ich alles ab der Spalte K nach rechts löschen, bevor das Transponieren beginnt?
Viele Grüße
Kisska

6
Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

AW: Makro verbessern

02.03.2020 09:01:43

hary
AW: Makro verbessern

03.03.2020 00:32:03

Kisska
AW: Makro verbessern

02.03.2020 09:20:43

Uwe
AW: Makro verbessern

03.03.2020 00:50:24

Kisska
Als Schleifenversion

03.03.2020 01:11:20

Uwe
genial!

03.03.2020 01:17:54

Kisska

AW: Makro verbessern

02.03.2020 09:01:43

hary

Moin
Teste mal.

Sub TransponierenOhneLeerzellen()
Dim zelle As Range, Kop As Range
Dim letzteSpalte As Long, i As Long, Zeile As Long
Zeile = 1
For i = 2 To 28 Step 26
letzteSpalte = Cells(Zeile, Columns.Count).End(xlToLeft).Column
If letzteSpalte >= 11 Then
Range(Cells(Zeile, 11), Cells(Zeile, letzteSpalte)).ClearContents
End If
For Each zelle In Cells(i, 8).Resize(26, 1)
If zelle  "" Then
If Kop Is Nothing Then
Set Kop = zelle
Else
Set Kop = Union(Kop, zelle)
End If
End If
Next
If Not Kop Is Nothing Then
Kop.Copy
Cells(Zeile, 11).PasteSpecial Paste:=xlValues, Transpose:=True
Set Kop = Nothing
End If
Zeile = 2
Next
Application.CutCopyMode = False
End Sub

gruss hary

AW: Makro verbessern

03.03.2020 00:32:03

Kisska

Hallo Hary,
danke für die super Optimierung! Das Makro läuft einwandfrei.
Mir ist nur nicht klar, wo ich im Makro mehr Bereiche angebe, die kopiert und dann transponiert werden sollen.
In meinem geposteten Code habe ich nur 2 Bereiche angegeben, tatsächlich sind es 7:
H2:H27, H28:H53, H54:H79, H80:H105, H106:H131, H132:H157, H158:H183
Die Bereiche umfassen immer 26 Zellen bzw. Zeilen.
VG, Kisska

AW: Makro verbessern

02.03.2020 09:20:43

Uwe

Hallo Kisska,
z.B. so:

Sub TransponierenOhneLeerzellen()
Dim i As Long, j As Long
Dim varQ As Variant, varZ As Variant
'Nr 1
varQ = Range("H2:H27").Value
ReDim varZ(1 To 1, 1 To UBound(varQ))
For i = 1 To UBound(varQ)
If Len(varQ(i, 1)) Then
j = j + 1
varZ(1, j) = varQ(i, 1)
End If
Next i
Range("K1").Resize(, Columns.Count - 10) = ""
Range("K1").Resize(, UBound(varQ)).Value = varZ
j = 0
'Nr 2
varQ = Range("H28:H53").Value
ReDim varZ(1 To 1, 1 To UBound(varQ))
For i = 1 To UBound(varQ)
If Len(varQ(i, 1)) Then
j = j + 1
varZ(1, j) = varQ(i, 1)
End If
Next i
Range("K2").Resize(, Columns.Count - 10) = ""
Range("K2").Resize(, UBound(varQ)).Value = varZ
j = 0
End Sub

Gruß Uwe

AW: Makro verbessern

03.03.2020 00:50:24

Kisska

Hallo Uwe,
vielen Dank für diese tolle Optimierung - es läuft einwandfrei.
Eine Frage dazu: Ich möchte mehr Bereiche zum Kopieren und Transponieren hinzufügen. Insgesamt sind es 7 Bereiche: H2:H27, H28:H53, H54:H79, H80:H105, H106:H131, H132:H157, H158:H183
Transponiert werden die dann jeweils ab K1, K2, K3, K4, K5, K6 und K7.
Einige Teile deines Makros wiederholen sich. Kann man diese Teile irgendwie an den Anfang des Makros setzen, damit es für alle Bereiche gilt?
Ich meine einmal diesen Teil:

  ReDim varZ(1 To 1, 1 To UBound(varQ))
For i = 1 To UBound(varQ)
If Len(varQ(i, 1)) Then
j = j + 1
varZ(1, j) = varQ(i, 1)
End If
Next i

und diese Teile:

.Resize(, Columns.Count - 10) = ""

.Resize(, UBound(varQ)).Value = varZ

VG, Kisska

Als Schleifenversion

03.03.2020 01:11:20

Uwe

Hallo Kisska,

Sub TransponierenOhneLeerzellen()
Dim i As Long, j As Long, k As Long
Dim lngL As Long
Dim varQ As Variant, varZ As Variant
lngL = 26
Range("K1").Resize(7, Columns.Count - 10) = ""
For k = 1 To 7
varQ = Range("H" & k * lngL - lngL + 2).Resize(lngL).Value
ReDim varZ(1 To 1, 1 To UBound(varQ))
For i = 1 To UBound(varQ)
If Len(varQ(i, 1)) Then
j = j + 1
varZ(1, j) = varQ(i, 1)
End If
Next i
Range("K" & k).Resize(, UBound(varQ)).Value = varZ
j = 0
Next k
End Sub

Gruß Uwe

genial!

03.03.2020 01:17:54

Kisska

Wow, besten Dank Uwe für diese elegante Lösung! Bin immer wieder erstaunt, was ihr Helfer zaubern könnt!
VG, Kisska

Beliebteste Forumthreads (12 Monate)

Forumthread: Makro verbessern

6 Beiträge zum Forumthread Beiträge zu diesem Forumthread

Beliebteste Forumthreads (12 Monate)

6
Beiträge zum Forumthread

Beiträge zu diesem Forumthread