Excel und VBA: Formeln, Programmierung, Lösungen

StandardModule: Modul1

Sub Zusammenfassen()
   Dim iRow As Integer, iCol As Integer, iAct As Integer
   Dim iCountC As Integer, iRowLT As Integer, iRowLS As Integer
   iCol = 1
   Do Until IsEmpty(Cells(1, iCol))
      For iAct = iCol + 1 To WorksheetFunction.CountA(Rows(1))
         If Cells(1, iCol).Value = Cells(1, iAct).Value And _
            WorksheetFunction.CountA(Columns(iCol)) > 1 Then
            iRowLS = Cells(Rows.Count, iAct).End(xlUp).Row
            iRowLT = Cells(Rows.Count, iCol).End(xlUp).Row + 1
            Range(Cells(2, iAct), Cells(iRowLS, iAct)).Cut _
               Cells(iRowLT, iCol)
         End If
      Next iAct
      iCol = iCol + 1
   Loop
   Application.CutCopyMode = False
   For iCol = Range("IV1").End(xlToLeft).Column To 1 Step -1
      If WorksheetFunction.CountA(Columns(iCol)) = 1 Then
         Columns(iCol).Delete
      End If
   Next iCol
End Sub

    

Beiträge aus dem Excel-Forum zu den Themen Allgemein und Bearbeiten