Clever-Excel-Forum

Hallo liebe Forumsgemeinde,

ich habe eine Matrix die folgendermaßen aussieht: Bereich der "x" = "U4:AS507", Bereich Überschrift "A,B,C" = "T4:T507":

1    2 3 ...
A x1     x2
B x3
C
...

Ich habe mit einer VBA-Funktion es geschafft die nicht-leeren Zellen (im Beispiel die "x") zu filtern und nacheinander in einem anderen Tabellenblatt zu kopieren:

Sub Filter()

Dim dest As Long
Dim results As Range

For Each results In Worksheets("Kalkulation").Range("U4:AS507") 'Diese Range deckt den Bereich ab, wo sich die Inhalte befinden (also ohne Überschriften)

dest = Worksheets("start").Cells(Rows.Count, 11).End(xlUp).Row + 1 'Die Daten werden in das Tabellenblatt "Start" kopiert
If results <> "" Then Worksheets("Start").Cells(dest, 11) = results

Next
End Sub

Leider komme ich nicht darauf, wie ich am anderen Blatt die Überschriften den gefilterten Daten zuordnen kann.
Derzeit sieht das Ergebnis so aus:
x1
x2
x3
...

Wunsch wäre folgendes:
A x1
A x2
B x3

Würde mich freuen wenn mir jemand dabei helfen könnte.

Liebe Grüße
Walter

Hallo Walter,

ich hätte diese Lösung:

Code:
Option Explicit

Sub Filter()

  Dim i As Long, j As Long, k As Long

  Dim lngA As Long

  Dim arr()

  Dim feld

  feld = Worksheets("Kalkulation").Range("T4:AS6")

  lngA = Application.CountA(feld) - UBound(feld)

  ReDim arr(lngA, 1)

  For i = 1 To UBound(feld)

    arr(i - 0, 0) = feld(i, 1)

    For j = 2 To 45 - 21

      If feld(i, j) <> "" Then

        arr(k, 0) = feld(i, 1)

        arr(k, 1) = feld(i, j)

        k = k + 1

      End If

    Next j

  Next i

  With Worksheets("Start")

    .Range("K" & .Cells(.Rows.Count, 11).End(xlUp).Row + 1).CurrentRegion.ClearContents

    If k > 0 Then .Range("J2:K2").Resize(k) = (arr)

  End With

End Sub

Lieber Atilla!

Vielen Dank für deine Hilfe! Der Code funktioniert!

Liebe Grüße
Walter

wiesi0392

atilla

wiesi0392