Microsoft Excel

Excel und VBA: Formeln, Programmierung, Lösungen

Die Excel/VBA-Beispiele

Thema

Neue Anordnung einer Tabelle in zweitem Tabellenblatt

Gruppe

Sortieren

Problem

Die Daten aus der einen Tabelle sollen in einer neuen Tabelle neu angeordnet werden.

Lösung
Geben Sie den nachfolgenden Code in ein Standardmodul ein und weisen Sie ihn einer Schaltfläche zu.

StandardModule: basMain

Sub TabUmwandeln()
   Dim wks As Worksheet
   Dim var As Variant
   Dim iRowL As Integer, iRow As Integer, _
      iCol As Integer, iRowT As Integer
   Dim iColT As Integer
   Dim sLager As String
   iRowL = Cells(Rows.Count, 1).End(xlUp).Row
   Set wks = ActiveSheet
   Worksheets.Add after:=Worksheets(wks.Index)
   iRowT = 1
   For iRow = 1 To iRowL
      If IsEmpty(wks.Cells(iRow, 2)) Then
         If IsEmpty(Range("B1")) Then
            iCol = 2
         Else
            iCol = Cells(1, Columns.Count).End(xlToLeft).Column + 1
         End If
         Cells(1, iCol).Value = wks.Cells(iRow, 1).Value
         sLager = wks.Cells(iRow, 1).Value
      Else
         var = Application.Match(wks.Cells(iRow, 1).Value, Columns(1), 0)
         If IsError(var) Then
            iRowT = iRowT + 1
            Cells(iRowT, 1).Value = wks.Cells(iRow, 1).Value
            Cells(iRowT, 2).Value = wks.Cells(iRow, 2).Value
         Else
            iColT = WorksheetFunction.Match(sLager, Rows(1), 0)
            Cells(var, iColT).Value = _
               Cells(iRowT, iColT).Value + wks.Cells(iRow, 2).Value
         End If
      End If
   Next iRow
   Cells(1, iCol + 1).Value = "Gesamt"
   iRow = 2
   Do Until IsEmpty(Cells(iRow, 1))
      Cells(iRow, iCol + 1).Value = _
         WorksheetFunction.Sum(Range(Cells(iRow, 2), Cells(iRow, iCol)))
      iRow = iRow + 1
   Loop
   Rows(1).Font.Bold = True
   Rows(1).HorizontalAlignment = xlRight
End Sub