Von mehreren Exceldateien Wert auslesen

Question

Hallo
Ich habe viele Excel-Dateien (Dateiname beinhaltet Datum) in einem Ordner.
Den Wert, den ich bräuchte steht allerdings immer in einer anderen Zeile, aber immer in der gleichen Spalte, kann man diesen Wert von jeder Datei irgendwie raus lesen und dann in eine separate Datei speichern in Verbindung mit dem Dateinamen ?
Gruß

Answer 1

Hi,

sicher kannst du (oder jemand anders ;) das in einem Makro machen. Woran erkennst du denn wo der Wert steht (z.B. immer neben/unter einem bestimmten Text oder ist die Zelle speziell immer formatiert ...)

Also in einem Macro in einer seperaten xlsm-Datei kannst du:

a) das Inhaltsverzeichniss eines Ordners (den du dafür anlegst) nach excel-dateien durchsuchen.
b) Dann in einer schleife jeweils
b1) Datei öffnen
b2) Wert finden und lesen.
b3) Wert und Dateiname in deiner xlsmdatei irgendwo hinschreiben
b4) Datei wieder schließen.
b5) Die verarbeitete Datei würde ich dann in einen anderen Ordner verschieben damit du beim nächsten Aufruf nicht die gleichen nochmal öffnest.

das läuft dann so lange bis alle dateien ausgelesen sind.

In den 5 Minuten seit dem ich dein Problem kenne habe ich natürlich noch nicht ein Macro fertig, ich schaue aber gleich vielleicht ob ich ein wenig vorbereiten kann. Muss aber auch noch andere sachen machen.

Answer 2

das folgende Macro kommt dann in eine xlsm-Datei.
Auf dem ersten Blatt habe ich dann in A1 Dateiname und in B1 Wert geschrieben. Darunter wird jeder neue gefudnende Wert in Zeile 2 eingefügt.

Sub lesedateien()
Dim myWorkbook As Workbook
Dim targetSheet, mySheet As Worksheet
Dim myExtension, myFilename, mypath As String
Dim i As Integer

' Pfad mit xlsx Dateien
mypath = "D:\test\"
myExtension = "*.xlsx"

Set targetSheet = Application.ActiveWorkbook.Sheets(1)
myFilename = Dir(mypath & myExtension, vbNormal)
While myFilename <> ""
' Exceldatei öffnen
Set myWorkbook = Workbooks.Open(mypath & myFilename)

' Arbeitsblatt festlegen (Name oder Indexnummer z.B. "Tabelle1" oder 1) Set mySheet = myWorkbook.Sheets(1) / Set mySheet = myWorkbook.Sheets("Tabelle1")
Set mySheet = myWorkbook.Sheets(1)

' Es gibt auch in VBA die möglichkeit direkt ein Blatt nach einem bestimmten Wert zu durchsuchen, oder wenn du die Spalte weißt, dann könntest du die Spalte Zeile für Zeile durchgehen:
' Wir lesen bis Zeile 5000 den Wert in Spalte 3 und wenn er "meineüberschrift" findet, dann füge Dateiname und Wert ein, der darunter steht.
For i = 1 To 5000
' Zeile, Spalte
If mySheet.Cells(i, 3).Value = "meineüberschrift" Then
targetSheet.Rows("2:2").Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
targetSheet.Cells(2, 1).Value = myFilename
targetSheet.Cells(2, 2).Value = mySheet.Cells(i + 1, 3).Value
i = 9999
End If
Next i

' Exceldatei schließen
myWorkbook.Close

' Datei nach processed kopieren und löschen
FileCopy mypath & myFilename, mypath & "processed\" & myFilename
Kill Path & myFilename
myFilename = Dir(mypath & myExtension, vbNormal)
Wend
End Sub

Answer 3

Hallo MixMax,
ich danke dir mal schon im voraus,
wenn ich morgen im Geschäft bin, dann schaue ich noch genauer nach wo der Wert steht, bzw. neben welche Zelle er steht.

Kannst du mir vielleicht noch kurz sagen, wie ich dann dieses Macro in die neue Exceldatei bringe ?
Wahrscheinlich so:
-Macro kopieren
-in Visual Basic gehen
-und dort irgendwo hinkopieren -> aber wohin

Gruß

Answer 4

Hallo Andi007 :-)

1)Alt+F11 öffnet den VBed
2)Oberen Menüs > einfügen Modul
3)In diesen Modul deinen Code einfügen

Gruss Nighty

Answer 5

Hallo MixMax

den Wert, den ich bräuchte steht immer neben dem Wort: "Fehlteile"
Also das Wort "Fehlteile" steht immer in Spalte A aber wie schon gesagt immer in einer anderen Zeile
und der Wert den ich bräuchte steht dann in der Spalte B

Gruß

Answer 6

Dann änderst du die Schleife so, dass du immer noch von Zeile 1 bis 5000 die Tabelle durchschaust,
aber in Spalte 1 vergleichst [(i, 1).Value = "Fehlteile"]
und beim einfügen der Zeile den wert von Spalte 2 der gleichen Zeile einfügst [mySheet.Cells(i, 2).Value]

For i = 1 To 5000
' Zeile, Spalte
If mySheet.Cells(i, 1).Value = "Fehlteile" Then
targetSheet.Rows("2:2").Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
targetSheet.Cells(2, 1).Value = myFilename
targetSheet.Cells(2, 2).Value = mySheet.Cells(i, 2).Value
i = 9999
End If
Next i

Answer 7

Hallo MixMax

Habe es jetzt ausprobiert, aber hier bleibt er stehen:

FileCopy mypath & myFilename, mypath & "processed\" & myFilename


Und einen Wert hat er mir in die Tabelle geschrieben

Answer 8

Hallo MixMax .-)

Ein paar Tips zum Code!
Deklarierung von Variablen > www.vba-tutorial.de/variablen/datentypen.htm
Nutze für die Suche > Find > https://msdn.microsoft.com/VBA/Excel-VBA/articles/range-find-method-excel
Grenze die Bereiche nach der letzten genutzten Zeile ein

'Letzte beschriebene zeile eines Worksheets
Cells(1, 1) = ActiveSheet.UsedRange.SpecialCells(xlCellTypeLastCell).Row
'Letzte beschriebene Spalte eines Worksheets
Cells(2, 1) = ActiveSheet.UsedRange.SpecialCells(xlCellTypeLastCell).Column
'Letzte beschriebene zeile einer Spalte,die 1 steht fuer Spalte A
Cells(3, 1) = ActiveSheet.Cells(Rows.Count, 1).End(xlUp).Row
'Letzte beschriebene Spalte einer Zeile,die 4 steht fuer zeile 4
Cells(4, 1) = ActiveSheet.Rows(4).End(xlToRight).Column

Gruß Nighty

Answer 9

Hallo

Und was heißt das jetzt für mich ?
Kann mir jemand dann nochmal das kompl. Macro aufzeigen ?
Wäre schön
Gruß

Answer 10

Hallo Community .-)

MixMax scheint überlastet ^^

Gruß Nighty

Ich bin mal von einem wert pro Datei ausgegangen!
6 und 7 Zele im Code anpassen,Dateiendung und Worksheetname

Deindung = "*.xls"
WksName = "Tabelle1"

Sub DateienLesen()
Call EventsOff
Dim Suche As Object
Dim DateiName As String, WksName As String, Dpfad As String, Deindung As String
Dim Lzeile As Long
Dpfad = CreateObject("Shell.Application").BrowseForFolder(0, "Ordner auswählen", &H1000, 17).items().Item().Path & "\"
Deindung = "*.xls"
WksName = "Tabelle1"
DateiName = Dir(Dpfad & Deindung)
Do While DateiName <> ""
If ThisWorkbook.Name <> DateiName Then
Workbooks.Open Filename:=Dpfad & DateiName
If SheetExists("" & WksName) = True Then
Set Suche = Worksheets("" & WksName).Range("A2:A11").Find("Fehlteile")
If Not Suche Is Nothing Then
Lzeile = ThisWorkbook.Worksheets(1).Cells(Rows.Count, 1).End(xlUp).Row + 1
ThisWorkbook.Worksheets(1).Cells(Lzeile, 1) = Worksheets("" & WksName).Cells(Suche.Row, 2)
ThisWorkbook.Worksheets(1).Cells(Lzeile, 2) = DateiName
End If
End If
Workbooks(DateiName).Close SaveChanges:=False
End If
DateiName = Dir
Loop
Call EventsOn
End Sub

Public Function SheetExists(strName As String) As Boolean
On Error Resume Next
SheetExists = Not Worksheets(strName) Is Nothing
End Function

Public Sub EventsOff()
With Application
.ScreenUpdating = False
.EnableEvents = False
.Calculation = xlCalculationManual
End With
End Sub

Public Sub EventsOn()
With Application
.ScreenUpdating = True
.EnableEvents = True
.Calculation = xlCalculationAutomatic
End With
End Sub

]