Dieses Forum nutzt Cookies
Dieses Forum verwendet Cookies, um deine Login-Informationen zu speichern, wenn du registriert bist, und deinen letzten Besuch, wenn du es nicht bist. Cookies sind kleine Textdokumente, die auf deinem Computer gespeichert werden. Die von diesem Forum gesetzten Cookies werden nur auf dieser Website verwendet und stellen kein Sicherheitsrisiko dar. Cookies aus diesem Forum speichern auch die spezifischen Themen, die du gelesen hast und wann du zum letzten Mal gelesen hast. Bitte bestätige, ob du diese Cookies akzeptierst oder ablehnst.

Ein Cookie wird in deinem Browser unabhängig von der Wahl gespeichert, um zu verhindern, dass dir diese Frage erneut gestellt wird. Du kannst deine Cookie-Einstellungen jederzeit über den Link in der Fußzeile ändern.

VBA: Bereich durchsuchen, Nichtleere-Zellen kopieren
#1
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
Antworten Top
#2
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
Gruß Atilla
[-] Folgende(r) 1 Nutzer sagt Danke an atilla für diesen Beitrag:
  • wiesi0392
Antworten Top
#3
Lieber Atilla!

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

Liebe Grüße
Walter
Antworten Top


Gehe zu:


Benutzer, die gerade dieses Thema anschauen: 1 Gast/Gäste