Makro verbessern

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

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

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

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

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

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

Beliebteste Forumthreads (12 Monate)

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

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

6
Beiträge zum Forumthread

Beiträge zu diesem Forumthread