VBA: Bereich durchsuchen, Nichtleere-Zellen kopieren

[wiesi0392]

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

[atilla]

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

[wiesi0392]

Lieber Atilla!

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

Liebe Grüße
Walter