welche Formel

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Benutzer

' ********************************************************************** ' Modul: Modul1 Typ: Allgemeines Modul ' ********************************************************************** Option Explicit Sub transposeData() Dim lngLast As Long, lngRow As Long, lngLastCol As Long, lngCol As Long Dim lngNewRows As Long, lngIndex As Long Dim vntNew() As Variant With ActiveSheet lngLast = Application.Max(3, .Cells(.Rows.Count, 1).End(xlUp).Row) lngLastCol = .Cells(1, .Columns.Count).End(xlToLeft).Column lngNewRows = Application.CountA(.Range(.Cells(3, 2), .Cells(lngLast, lngLastCol))) Redim vntNew(1 To lngNewRows, 1 To 3) For lngRow = 3 To lngLast If Application.Count(.Range(.Cells(lngRow, 2), .Cells(lngRow, lngLastCol))) > 0 Then For lngCol = 2 To lngLastCol If .Cells(lngRow, lngCol) <> "" Then lngIndex = lngIndex + 1 vntNew(lngIndex, 1) = .Cells(lngRow, 1) vntNew(lngIndex, 2) = .Cells(1, lngCol) vntNew(lngIndex, 3) = .Cells(lngRow, lngCol) End If Next End If Next End With If lngIndex > 0 Then Worksheets.Add after:=ActiveSheet With ActiveSheet .Cells(1, 1).Resize(lngNewRows, 3) = vntNew .Range("A1").CurrentRegion.Sort Key1:=.Range("A1"), Order1:=xlAscending, _ Key2:=.Range("B1"), Order2:=xlAscending, Header:=xlNo End With End If End Sub

Hallo Antje,
im Allgemeinen erwarte ich, das eine Beispieltabelle vom Aufbau her dem Original entspricht, vor allem bei "VBA nein".
Ich hab dir drei Konstanten eingefügt mit denen du denCode einfach an deine Bedürfnisse anpassen kannst.
Und ja, die Größe des Datenbereiches wird vom Makro automatisch ermittelt.

' **********************************************************************
' Modul: Modul1  Typ: Allgemeines Modul
' **********************************************************************
Option Explicit
Const clngFirstDataColumn As Long = 1 'Spalte mit den Kostenstellen
Const clngFirstDataRow As Long = 3  'Erste Zeile mit Daten
Const clngHeaderRow As Long = 1 'Zeile mit den Konten
Sub transposeData()
  Dim lngLast As Long, lngRow As Long, lngLastCol As Long, lngCol As Long
  Dim lngNewRows As Long, lngIndex As Long
  Dim vntNew() As Variant
  With ActiveSheet
    lngLast = Application.Max(clngFirstDataRow, .Cells(.Rows.Count, clngFirstDataColumn).End(xlUp).Row)
    lngLastCol = .Cells(clngHeaderRow, .Columns.Count).End(xlToLeft).Column
    lngNewRows = Application.CountA(.Range(.Cells(clngFirstDataColumn, clngFirstDataColumn + 1), .Cells(lngLast, lngLastCol)))
    Redim vntNew(1 To lngNewRows, 1 To 3)
    
    For lngRow = clngFirstDataRow To lngLast
      If Application.Count(.Range(.Cells(lngRow, clngFirstDataColumn + 1), .Cells(lngRow, lngLastCol))) > 0 Then
        For lngCol = 2 To lngLastCol
          If .Cells(lngRow, lngCol) <> "" Then
            lngIndex = lngIndex + 1
            vntNew(lngIndex, 1) = .Cells(lngRow, clngFirstDataColumn)
            vntNew(lngIndex, 2) = .Cells(clngHeaderRow, lngCol)
            vntNew(lngIndex, 3) = .Cells(lngRow, lngCol)
          End If
        Next
      End If
    Next
  End With
  If lngIndex > 0 Then
    Worksheets.Add after:=ActiveSheet
    With ActiveSheet
      .Cells(1, 1).Resize(lngNewRows, 3) = vntNew
      .Range("A1").CurrentRegion.Sort Key1:=.Range("A1"), Order1:=xlAscending, _
        Key2:=.Range("B1"), Order2:=xlAscending, Header:=xlNo
    End With
  End If
End Sub

« Gruß Sepp »

Beliebteste Forumthreads (12 Monate)

7 Beiträge zum Forumthread Beiträge zu diesem Forumthread

VBA Beispiele zu verwandten Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

7
Beiträge zum Forumthread

Beiträge zu diesem Forumthread