Do While Schleife(n)

Hallo liebe Gemeinde,
ich brauche wieder einmal Eure Hilfe. Mein Ziel ist es mit einem Makro aus verschiedenen Datei Werte auszulesen. Die ersten Daten sind immer erst ab Zeile 15 zu finden. In den Quelldateien sind allerdings unterschiedlich viele Einträge, so dass ich den Lesevorgang beenden kann, wenn in Tabelle1 in Spalte C die erste leere Zelle steht.
Ich habe ein Makro aufgebaut, dass jede im definierten Suchpfad gespeicherte Datei öffnet und die in meinem Tabellenblatt "lesen" definierten Ordner und Zellen anspricht und mir die Daten im Ordner gelesen abliefert. Folgende Probleme habe ich derzeit:
1. Die Quelldatei wird geöffnet und der erste Datensatz jeweils aus Zeile 15 ausgelesen, wie bekomme ich das hin, dass in der Quelldatei mit der Folgezeile weitergearbeitet wird (wahrscheinlich eine zweite Schleife aufsetzen - aber wie).
2. Derzeit definiere ich in der Spalte 3 meiner "Lesetabelle" die anzusprechende Spalte, die durch das Makro ausgelesen wird:
QUCell = Workbooks(myWB).Sheets("lesen").Cells(LZ, 4).Value
in Spalte C der Buchstabe der Spalte, jedoch würde ich gerne Cells(LZ, 4) nach dem Prinzip Cells(LZ, 3 und Quellzeile) haben. Meine Bemühungen mit & zu arbeiten gingen in die Hose. Habt Ihr einen Tipp?
Ich lege mal eine Testdatei an - die das Problem verdeutlicht.
https://www.herber.de/bbs/user/95606.xlsm
Danke Euch im voraus
Ron

Beitrag zum Forumthread

Beitrag zu diesem Forumthread

Betreff

Datum

Anwender

Hallo,
mein Freitag - Problem habe ich gelöst. Zumindest läuft u.a. Makro erst einmal und macht das, was es soll:
- Blatt gelesen - Inhalte löschen
- aus Suchpfad Dateien öffnen und die im Blatt Lesen in Spalte B definierten Tabellenblätter und Spalte D definierten Zellen Werte aus der geöffneten Datei auslesen und in den Ordner gelesen übertragen
- das wird mir jeder Datei im Suchpfad erledigt
- da in den angesprochenen Dateien doppelte Einträge mit identischen Werten vorkommen, wird zum Schluß im Ordner gelesen alles doppelte gelöscht
So weit so gut - Wenn ich jede "Aufgabe" mit einem einzelnen Makro erledige, geht alles sehr flott, lasse ich u.a. Script laufen, dauert es einfach zu lange (Dateien liegen lokal)
Könnt Ihr einen Fehler erkennen oder mir einen Hinweis geben, wie ich das Ding beschleunigen kann?
Danke im voraus
Ron

Sub Zusammenführen_mehrerer_Werte_aus_Bericht()
Dim Datei As String, Pfad As String
Dim objDatei As Workbook
Dim QUTB, QUCell, myValue, myWB, QUle As String
Dim QZ, LZ, ZZ, ZS As Integer
Application.ScreenUpdating = False
'löscht alle Daten ab Zeile 2 im Ordner "Gelesen"
If Sheets("gelesen").Range("A2")  "" Then
Sheets("gelesen").Activate
Range("A2:ec" & ActiveSheet.UsedRange.Rows.Count).Clear
End If
Application.Calculation = xlAutomatic
ChDir Sheets("Lesen").Range("b4")
Pfad = Sheets("Lesen").Range("b4")
Datei = Dir$(Pfad & "\*.xls")
myWB = ThisWorkbook.Name
LZ = 7 'erste Zeile der Lesedaten für Ordner Lesen bestimmen
ZZ = 2 'erste Zielzeile für Ordner Gelesen bestimmen
ZS = 1 'erste Zielspalte für Ordner Gelesen bestimmen
QZ = 15 'erste zu lesende Zeile in der Quelldatei
Workbooks(myWB).Sheets("lesen").Cells(6, 4).Value = QZ
Do While Datei  ""
Set objDatei = Workbooks.Open(Datei, , True)
QUle = Workbooks(myWB).Sheets("Lesen").Cells(7, 2).Value
Do Until objDatei.Sheets(QUle).Cells(QZ, 3) = ""
If objDatei.Sheets(QUle).Cells(QZ, 3)  "" Then
Do Until IsEmpty(Workbooks(myWB).Sheets("Lesen").Cells(LZ, 1).Value)
If Workbooks(myWB).Sheets("Lesen").Cells(LZ, 1).Value  "" Then
QUTB = Workbooks(myWB).Sheets("Lesen").Cells(LZ, 2).Value
QUCell = Workbooks(myWB).Sheets("Lesen").Cells(LZ, 4).Value
myValue = objDatei.Sheets(QUTB).Range(QUCell).Value
Workbooks(myWB).Sheets("gelesen").Cells(ZZ, ZS) = myValue
LZ = LZ + 1 'Zähler Quelldaten auf nächster Zeile setzen
ZS = ZS + 1 'Zähler Zielspalte auf nächste Spalte setzen
Else
End If
Loop
Else
End If
ZZ = ZZ + 1
ZS = 1
LZ = 7
QZ = QZ + 1
Workbooks(myWB).Sheets("lesen").Cells(6, 4).Value = QZ
Loop
objDatei.Close False
Datei = Dir$()
'ZZ = ZZ + 1 'Zähler der Zielzeile auf nächste Zeile setzen
LZ = 7 'Zähler der Quelldaten wieder zurücksetzen
ZS = 1 'Zähler der Zielspalte wieder zurücksetzen
QZ = 15
Workbooks(myWB).Sheets("lesen").Cells(6, 4).Value = QZ
Loop
Sheets("gelesen").Activate
With ActiveSheet.UsedRange
With .Columns(.Columns.Count).Offset(0, 1)
.Formula = "=If(Countif(A$1:A1,A1)=1,true,0)"
.Formula = .Value
.EntireRow.Sort Key1:=.Cells(1, 1), Order1:=xlAscending, Header:=xlNo
On Error Resume Next
.SpecialCells(xlCellTypeConstants, 1).EntireRow.Delete
On Error GoTo 0
.EntireColumn.Delete
End With
End With
Sheets("lesen").Activate
Application.ScreenUpdating = True
End Sub

Beliebteste Forumthreads (12 Monate)

1
Beitrag zum Forumthread

Beitrag zu diesem Forumthread

301 Forumthreads zu ähnlichen Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

Do While Schleife(n)

1 Beitrag zum Forumthread Beitrag zu diesem Forumthread

301 Forumthreads zu ähnlichen Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

1
Beitrag zum Forumthread

Beitrag zu diesem Forumthread