Live-Forum - Die aktuellen Beiträge
Datum
Titel
28.03.2024 21:12:36
28.03.2024 18:31:49
Anzeige
Archiv - Navigation
1072to1076
Aktuelles Verzeichnis
Verzeichnis Index
Übersicht Verzeichnisse
Vorheriger Thread
Rückwärts Blättern
Nächster Thread
Vorwärts blättern
Anzeige
HERBERS
Excel-Forum (Archiv)
20+ Jahre Excel-Kompetenz: Von Anwendern, für Anwender
Inhaltsverzeichnis

Aus mehreren Tabellenblättern Daten auslesen

Aus mehreren Tabellenblättern Daten auslesen
17.05.2009 14:37:22
Manuel
Hallo und einen schönen Sonntag,
ich habe eine Arbeitsmappe, mit 152 Tabellenblättern, hier soll mir das Makro als Referenz die Zeile B nehmen und soll dort jeweils die Zeilen welche "irgendwas" enthalten in einen neue Datei kopieren.
Das derzeitige Script, erstellt die neue Datei und Kopiert aus dem aktuell gewählten Tabellenblatt die entsprechenden Zeilen 152 Mal in die neue Datei.

Sub Makro3()
Workbooks.Open Filename:="D:\Users\X\Documents\hilfsdatei.xls"
Windows("Testfallerstellung").Activate
Dim i As Long
Dim laR As Long
Dim lZeile As Long
Dim objWks    As Worksheet
Dim nCounter  As Integer
Dim nNumWS    As Integer
lZeile = 4
Application.ScreenUpdating = False
Windows("Testfallerstellung").Activate
laR = Cells(Rows.Count, 4).End(xlUp).Row
nNumWS = ActiveWorkbook.Worksheets.Count
'MsgBox nNumWS
For nCounter = 1 To nNumWS
Windows("Testfallerstellung").Activate
Set objWks = ActiveWorkbook.Worksheets(nCounter)
MsgBox nCounter
For i = laR To 4 Step -1
If Cells(i, 2).Value  "" Then
MsgBox ActiveWorkbook.Name
Windows("Testfallerstellung").Activate
'Set objWks = ActiveWorkbook.Worksheets(nCounter)
Cells(i, 1).EntireRow.Select
Selection.Copy
Windows("hilfsdatei").Activate
Range("A" & lZeile).Select
ActiveSheet.Paste
lZeile = lZeile + 10
'MsgBox ActiveWorkbook.Name
End If
Next i
Set objWks = Nothing
Next nCounter
Application.ScreenUpdating = True
End Sub


mfg Manuel

1
Beitrag zum Forumthread
Beitrag zu diesem Forumthread

Betreff
Datum
Anwender
Anzeige
AW: Aus mehreren Tabellenblättern Daten auslesen
17.05.2009 18:23:25
Manuel
Lösung gefunden ->

Sub NeueDatei2()
' Bildschirmaktualisierung AUSschalten (Makro läuft schneller, Bildschirm flackert nicht)
Application.ScreenUpdating = False
' Andere Datei öffnen
Workbooks.Open Filename:="D:\Users\beateboenigk\Documents\hilfsdatei.xls"
' Zurück ins auszuführende Fenster
Windows("Testfallerstellung_Kreditkarte_20090511").Activate
' Variablen deklarieren
Dim g As Worksheet
Dim lZeile As Long
' Sheets nacheinander Auswählen
For Each g In ThisWorkbook.Worksheets
' Die Variable lngLetzte wird als Typ Long deklariert
Dim lngLetzte As Long
' Die Variable lngZeile wird als Typ Long deklariert
Dim lngZeile As Long
' Letzte belegte Zelle in Spalte C plus 1 raussuchen und merken
lngLetzte = IIf(IsEmpty(Range("C65536")), Range("C65536").End(xlUp).Row + 1, 65536)
' in einer Schleife von dieser Letzten bis Zeile 1 gehen - also von unten nach oben
For lngZeile = lngLetzte To 4 Step -1
' Aktuelles Worksheet Aktivieren
Worksheets(g.Name).Activate
' Wenn die Zelle in der ensprechenden Zeile in Spalte C nicht leer ist
If Cells(lngZeile, 3)  "" Then
' dann kopiere die gesamte Zeile
' folgendes ist eine spezifische Ausführung für meine Datei
sellnga = lngZeile
sellnge = lngZeile
' macht XX : XX und wählt damit die ganze Zeile aus
selrang = sellnga & ":" & sellnge
' MsgBox ActiveWorkbook.Name
' MsgBox ActiveSheet.Name
' MsgBox g.Name & "1"
' Aktuelles Worksheet Aktivieren
Worksheets(g.Name).Activate
' im Aktiven Worksheet die bestimmen Zeilen auswählen
Range(selrang).Select
' Auswahle Kopieren
Selection.Copy
' andere Datei Aufrufen
Windows("hilfsdatei").Activate
' Bereich auswählen und ...
Range("A65536").End(xlUp).Offset(1, 0).Select
' Range("A" & lZeile).Select
' ...einfügen
ActiveSheet.Paste
' Zurück ins ausführende Fenster
Windows("Testfallerstellung_Kreditkarte_20090511").Activate
' beim nächsten durchlauf 10 Zeilen später einfügen
'lZeile = lZeile + 10
' Ende der Bedingung
' Zwischenablage löschen
Application.CutCopyMode = False
End If
' Nächste Zeile mit der Bedingung vergleichen
Next
' MsgBox g.Name
Next g
' Bildschirmaktualisierung EINschalten (nicht vergessen)
Application.ScreenUpdating = True
End Sub


Anzeige

338 Forumthreads zu ähnlichen Themen

Anzeige
Anzeige
Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige
Anzeige
Anzeige