Live-Forum - Die aktuellen Beiträge
Datum
Titel
28.03.2024 21:12:36
28.03.2024 18:31:49
Anzeige
Archiv - Navigation
1460to1464
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

Messdaten auslesen

Messdaten auslesen
05.12.2015 16:29:53
Fritz
Guten Tag,
da ich bei meiner Fehlersuche immer wieder auf dies Forum stieß, jedoch nach über 2 Wochen noch immer zu keiner zufriedenstellenden Lösung gekommen bin, möchte
ich Euch bitten mir einen Rat zu geben oder mich auf evtl. Fehler aufmerksam zu machen.
Situation: Ich habe etwa 30 xls Mappen, mit je 33 Tabellen, aus denen ich versuche 2 bzw. 3 Werte (die Bezeichnungen stehen in der 1. Zeile) auszulesen und in ein neues Dokument zu speichern. Dazu habe ich das folgende Programm geschrieben:
Option Explicit

Sub test()
'Variablendeklaration
Dim WS As Worksheet
Dim WSName As String
Dim TabEnd As Integer
Dim i As Integer
'Zieldatei anlegen
Workbooks.Add
Application.CutCopyMode = False
ChDir "C:\Desktop"
ActiveWorkbook.SaveAs Filename:="C:\Desktop\Dauerspeicherdaten_Exzerp.xlsx", _
FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False '!ggf. Pfad anpassen!
ActiveWindow.Close
'geöffnete Mappe nach Schlüsselwörtern durchsuchen und darunterliegende Werte in zuvor  _
angelegte Zieldatei kopieren
For Each WS In ActiveWorkbook.Worksheets
WSName = WS.Name
TabEnd = Sheets(WS.Name).Columns.Count
'Debug.Print TabEnd
For i = 1 To TabEnd
If StrComp("Zeit2", Sheets(WSName).Cells(1, i)) = 0 Then
Sheets(WSName).Cells(2, i).Copy
Workbooks.Open Filename:= _
"Dauerspeicherdaten_Exzerp.xlsx"
Cells(Cells(Rows.Count, "A").End(xlUp).Row + 1, "A").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Application.CutCopyMode = False
ActiveWorkbook.Save
'Sheets(WSName).Select
ActiveWindow.Close
'Debug.Print Sheets(WSName).Cells(2, i)
Sheets(WSName).Cells(3, i).Copy
Workbooks.Open Filename:= _
"Dauerspeicherdaten_Exzerp.xlsx"
Cells(Cells(Rows.Count, "B").End(xlUp).Row + 1, "B").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Application.CutCopyMode = False
ActiveWorkbook.Save
ActiveWindow.Close
Sheets(WSName).Cells(4, i).Copy
Workbooks.Open Filename:= _
"Dauerspeicherdaten_Exzerp.xlsx"
Cells(Cells(Rows.Count, "C").End(xlUp).Row + 1, "C").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Application.CutCopyMode = False
ActiveWorkbook.Save
ActiveWindow.Close
End If
If StrComp("p_Umgebung", Sheets(WSName).Cells(1, i)) = 0 Then
Sheets(WSName).Cells(3, i).Copy
Workbooks.Open Filename:= _
"Dauerspeicherdaten_Exzerp.xlsx"
Cells(Cells(Rows.Count, "E").End(xlUp).Row + 1, "E").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Application.CutCopyMode = False
ActiveWorkbook.Save
ActiveWindow.Close
Sheets(WSName).Cells(4, i).Copy
Workbooks.Open Filename:= _
"Dauerspeicherdaten_Exzerp.xlsx"
Cells(Cells(Rows.Count, "F").End(xlUp).Row + 1, "F").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Application.CutCopyMode = False
ActiveWorkbook.Save
ActiveWindow.Close
End If
Next i
Next WS
End Sub
Im Anschluss führe ich die so entstandenen Exzerpe zusammen.
Mir ist bewusst, dass das Öffnen und schließen der Ziel-Datei bestimmt unständlich ist, eine Vereinfachung wäre wünschenswert. Ich bin auch für vereinfachende Tipps dankebar - nur erschien mir die Struktur günstig zum debuggen.
Als Fehler bekomme ich mal den berühmten Fehler 400, auch den Laufzeitfehler 9 "Index außerhalb des gültigen Bereichs" und den Fehler 1004 angezeigt.
Es funktioniert seltsamer Weise zuverlässig wenn ich die ersten 1-5 Tabellen einer Mappe lösche und die ersten 5 dann separat auswerte. Einmal funktionierte es auch, nachdem ich den aller ersten Wert der kopiert werden sollte von 2502 auf 1 änderte.
Von den verbleibenden 4 Werten von Interesse sind 2 Zahlen zwischen 950 und 1050 und 2 mal Daten der Form "30.04.2015 16:41" in einer Zelle. Pro Tabelle stehen die 4 Werte etwa 3 mal, eine Tabelle ist immer 256 Spalten breit, aber bis zu 40 000 Zeilen lang. Mich interessieren allerdings nur die Werte bis Zeile 4, darunter könnte man alles löschen mit einem Makro, aber das für all die Dateien umzusetzen mache ich nur, wenn es Erfolg verspricht, da ich das Makro noch manuell in der jeweiligen Mappe ausführen muss und es sich die Dateien nicht mit bspw.:
arg = "'" & path & "[" & file & "]" & sheet & "'!" & Cells(row, column).Address(ReferenceStyle:=xlR1C1)
'Ausführen des XL4-Makros
getValueFromFile = ExecuteExcel4Macro(arg)
selbst holt.
Liebe Community ich bitte um konstruktive Anregungen, da ich mit der Problematik inzwischen leider sehr in Zeitnot geraten bin.
Aufrichtigen Dank
Fritz
PS: beim debuggen werden mir im Falle, dass es nicht funktioniert, zumeist die Zeile
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
markiert. Die xlsm 's, sind zwischen 100MB und 300MB groß.

3
Beiträge zum Forumthread
Beiträge zu diesem Forumthread

Betreff
Datum
Anwender
Anzeige
AW: Messdaten auslesen
05.12.2015 20:36:03
Sepp
Hallo Fritz,
warum öffnest du die Zieldatei jedesmal neu?
Warum erstellst du den Code nicht in der Zieldatei und liest die Daten aus den anderen Dateien aus?
Das geht evtl. auch ohne die Quelldateien zu öffnen.
Wie sind die Quelldateien aufgebaut und welche Werte benötigst du? Beispiel?
Wie sollen die Daten in der Zieldatei dargestellt werden? Beispiel?
Liegen die Quelldateien alle im selben Ordner?
Sollen die Werte aus allen Tabellenblättern der Quelldateien ausgelesen werden?
Wie heißen die Tabellenblätter? Fixe Namen?
Gruß Sepp

Anzeige
AW: Messdaten sammeln und ausgeben
05.12.2015 21:55:11
Over
Hallo Fritz,
ich bin mir nicht sicher, ob ich dein Problem richtig verstanden habe.
Du hast rund 30 xls-Dateien mit je rund 33 Blättern, die alle ähnlich aufgebaut sind.
Du willst in den Spalten mit der Bezeichnung in Zeile 1 von "Zeit2" oder "p_Umgebung"
die darunter stehenden Werte (Zeile 2-3) auslesen und in einer extra Datei zusammenfassen (?)
Ich nehme jetzt mal an, deine Quell-Dateinamen lauten "Testmessdaten01.xls"; "Testmessdaten02.xls" usw.
dann würde ich über die äußere Schleife die Dateinamen ermitteln

Dateiname = Dir(LW & Pfad & Quell_Dat, vbNormal)
Do
Workbooks.Open Filename:=Dateiname
Workbooks(Dateiname).Close savechanges:=False
Dateiname = Dir()  'nächsten Dateinamen ermitteln
Loop Until Dateiname = ""
und über die innere Schleife alle Tabellenblätter nach den Werten abgrasen,
diese erstmal in eine Variable und erst am Schluss geschlossen in deine Ausgabedatei schreiben
es geht mit Sicherheit auch eleganter...

Type Messwerte
Quelle_Datei As String
Quelle_Tab As String
Datum1 As Date
Wert1 As Integer
Datum2 As Date
Wert2 As Integer
Datum3 As Date
Wert3 As Integer
End Type
'Dim Mess As Messwerte
Sub test_messdatensammeln()
'Variablendeklaration
Dim Mess(1 To 1000) As Messwerte ' 30 x 33 -->990 Sammelstellen
Dim WS As Worksheet
Dim TabEnd As Integer
Dim i As Integer
Dim Dateiname As String
M_zaehler = 0
LW = "C:\"
Pfad = "MeineDaten\"  'ggf anpassen
Quell_Dat = "Testmessdaten*.xls"
ChDrive LW
ChDir LW & Pfad
Dateiname = Dir(LW & Pfad & Quell_Dat, vbNormal) 'nur Dateien keine Verzeichisse
Do
Workbooks.Open Filename:=Dateiname
For Each WS In ActiveWorkbook.Worksheets
'letzte Spalte im Arbeitsblatt ermitteln
TabEnd = ActiveSheet.Cells.SpecialCells(xlCellTypeLastCell).Column
For i = 1 To TabEnd
'Spalte mit Zeitangabe finden
If Cells(1, i) = "Zeit2" Then
M_zaehler = M_zaehler + 1
Mess(M_zaehler).Quelle_Datei = ActiveWorkbook.Name ' nur für Test
Mess(M_zaehler).Quelle_Tab = WS.Name ' nur für Test
Mess(M_zaehler).Datum1 = WS.Cells(2, i)
Mess(M_zaehler).Datum2 = WS.Cells(3, i)
Mess(M_zaehler).Datum3 = WS.Cells(4, i)
End If
'Spalte mit Werten finden
If Cells(1, i) = "p_Umgebung" Then
Mess(M_zaehler).Wert1 = WS.Cells(2, i)
Mess(M_zaehler).Wert2 = WS.Cells(3, i)
Mess(M_zaehler).Wert3 = WS.Cells(4, i)
End If
Next i
Next WS
Workbooks(Dateiname).Close savechanges:=False
Dateiname = Dir()  'nächsten Dateinamen ermitteln
Loop Until Dateiname = ""   'leer, wenn keine weitere Datei den Kriterien entspricht
'---Ausgabe ---
Workbooks.Add
Cells(1, 1) = "Sammeldatei"
Cells(2, 1) = "Quell-Datei"
Cells(2, 2) = "Quell-Tabelle"
Cells(2, 3) = "Datum"
Cells(2, 4) = "p_Umgebung"
For i = 1 To M_zaehler
Cells(2 + (i - 1) * 3, 1) = Mess(i).Quelle_Datei
Cells(2 + (i - 1) * 3, 2) = Mess(i).Quelle_Tab
Cells(2 + (i - 1) * 3, 3) = Mess(i).Datum1: Cells(2 + (i - 1) * 3, 4) = Mess(i).Wert1
Cells(2 + (i - 1) * 3 + 1, 3) = Mess(i).Datum2: Cells(2 + (i - 1) * 3 + 1, 4) = Mess(i).Wert2
Cells(2 + (i - 1) * 3 + 2, 3) = Mess(i).Datum3: Cells(2 + (i - 1) * 3 + 2, 4) = Mess(i).Wert3
Next i
'ActiveWorkbook.SaveAs Filename:="C:\Desktop\Dauerspeicherdaten_Exzerp.xlsx", _
FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False '
End Sub

Lg
Daniel Ov

Anzeige
AW: Messdaten sammeln und ausgeben
05.12.2015 22:00:25
Over
statt
TabEnd = ActiveSheet.Cells.SpecialCells(xlCellTypeLastCell).Column
müsste es natürlich hier
TabEnd = WS.Cells.SpecialCells(xlCellTypeLastCell).Column
lauten...

Beliebteste Forumthreads (12 Monate)

Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige
Anzeige
Anzeige