Excel Datei - Werte per Macro auslesen

Liebe VBA Experten!

Habe folgendes Problem: eine Excel Datei mit ins. 14 Arbeitsblättern (1-4 sind Kalkulationen, welche auf 5-14 zugreifen.

Ich möchte nun entweder in einer neuen Datei, oder in einem 15 Arbeitsblatt alle Zeilen der Arbeitsblätter 5-14 auslesen, welche in der Spalte D (ab Zeile 5) den Wert > 1 haben (vorzugsweise nicht die ganze Zeile sondern nur Spalten B-D)

Ich habe zwar einige ähnliche Problemstellungen in diesem Forum gefunden, aber als absoluter VBA Neuling schaffe ich das ohne fremde Hilfe nicht.

Danke schon mal im Voraus.

cico

Bitte markiere auch die Kommentare, die zur Lösung des Beitrags beigetragen haben

Content-ID: 108149

Url: https://administrator.de/forum/excel-datei-werte-per-macro-auslesen-108149.html

Ausgedruckt am: 23.05.2025 um 08:05 Uhr

2 Kommentare

Neuester Kommentar

Hallo cico2610!

Das ließe sich zwar auch kürzer schreiben, aber ich habe versucht, das Ganze etwas allgemeiner zu halten:

Sub Zusammenfassen()
QSVon = "B" 'erste zu übertragende Spalte der Quelltabelle  
QSBis = "D" 'letzte zu übertragende Spalte der Quelltabelle  
QSKrit = "D" 'Spalte der Quelltabelle, welche als Kriterium herangezogen wird  
QZVon = 5 'erste zu übertragende Zeile der Quelltabelle  
Set ZT = Worksheets("Zusammenfassung") 'Name der Zieltabelle  
ZS = "A" 'Spalte, ab welcher die Daten in die Zieltabelle geschrieben werden sollen  
ZZ = 2 'Zeile, ab welcher die Daten in die Zieltabelle geschrieben werden sollen  

ZSAnz = Range(Cells(1, QSVon), Cells(1, QSBis)).Columns.Count ' Anzahl der zu übertragenden Spalten ermitteln  

For i = 5 To 14 'lfd Tabellennummern der Quelltabellen (alternativ: Array mit den Namen der Quelltabellen verwenden)  
    QZ = QZVon 'in Zeile, ab welcher aus der jeweiligen Quelltabelle Daten übernommen werden sollen, starten  
    With Worksheets(i) 'Quelltabelle  
        Do While .Cells(QZ, QSKrit).Value <> "" 'Schleife, solange in der Kriterienspalte noch Daten vorhanden sind  
            If .Cells(QZ, QSKrit).Value > 1 Then 'hier das Kriterium (">1") festlegen  
                Daten = .Range(.Cells(QZ, QSVon), .Cells(QZ, QSBis)).Value 'Werte aus der Quelltabelle in Array übertragen  
                ZT.Cells(ZZ, ZS).Resize(1, ZSAnz) = Daten 'Array in Zieltabelle schreiben  
                ZZ = ZZ + 1 'nächste Zeile der Zieltabelle festlegen  
            End If
            QZ = QZ + 1 'nächste Zeile der Quelltabelle festlegen  
        Loop
    End With
Next
End Sub