VBA: Informationen mittels Makro aus anderen Dateien auslesen

Question

Hallo zusammen,

leider kenne ich mich mit VBA nicht so gut aus, daher meine Frage an alle Experten:

Ich hab hier einige Dateien, die alle exakt gleich aufgebaut sind, aus denen ich Daten in eine Excelliste auslesen bzw. übertrage will.
Meine Vorstellung wäre, dass beim Klick auf einen Button alle Dateien in einem Ordner durchsucht werden, ob ein bestimmt Zelle ausgefüllt ist (E2). Sollte dies der Fall sein sollen verschiedene Zellen (B2:B10) ausgelesen und ab Zeile 11 in die Liste übertragen werden. Dabei soll für jede ausgelesene Datei eine extra Zeile angelegt werden. Schön wäre auch eine vorherige Überprüfung, ob der übertrage Name bereits vorhanden ist, um Doppeleinträge zu vermeiden.

Gibt es eine Möglichkeit sowas über ein Makro zu regeln?
Vielen Dank im Voraus!

Greetz andyamo

Answer 1

hi all :-)

b2 waere der suchbegriff fuer die pruefung auf doppelte in spalte a

gruss nighty

Option Explicit

Sub DateienLesen()
Dim DateiName As String, ZellPos As Variant
Dim Lzeile As Long, Lspalte As Long
Dim suche As Range
DateiName = Dir("C:\Temp\" & "*.xls")
Lzeile = 2
Do While DateiName <> ""
If ExecuteExcel4Macro("'C:\Temp\" & "[" & DateiName & "]Tabelle1" & "'!" & Range("E2").Address(, , xlR1C1)) <> 0 Then
Set suche = Worksheets("Tabelle1").Range("A1:A" & Worksheets("Tabelle1").UsedRange.SpecialCells(xlCellTypeLastCell).Row).Find(ExecuteExcel4Macro("'C:\Temp\" & "[" & DateiName & "]Tabelle1" & "'!" & Range("B2").Address(, , xlR1C1)))
If suche Is Nothing Then
For Each ZellPos In Array("B2", "B3", "B4", "B5", "B6", "B7", "B8", "B9", "B10")
Lspalte = Lspalte + 1
Cells(Lzeile, Lspalte) = ExecuteExcel4Macro("'C:\Temp\" & "[" & DateiName & "]Tabelle1" & "'!" & Range("" & ZellPos).Address(, , xlR1C1))
Next ZellPos
Lspalte = 0
Lzeile = Lzeile + 1
End If
End If
DateiName = Dir
Loop
End Sub

Answer 2

hi all :-)

ein wenig optimiert

gruss nighty

Option Explicit

Sub DateienLesen()
Call EventsOff
Dim DateiName As String, ZellPos As Variant
Dim Lzeile As Long, Lspalte As Long
Dim suche As Range
DateiName = Dir("C:\Temp\" & "*.xls")
Lzeile = 11
Do While DateiName <> ""
If ExecuteExcel4Macro("'C:\Temp\" & "[" & DateiName & "]Tabelle1" & "'!" & Range("E2").Address(, , xlR1C1)) <> 0 Then
Set suche = Range("A1:A" & ActiveSheet.UsedRange.SpecialCells(xlCellTypeLastCell).Row).Find(ExecuteExcel4Macro("'C:\Temp\" & "[" & DateiName & "]Tabelle1" & "'!" & Range("B2").Address(, , xlR1C1)))
If suche Is Nothing Then
For Each ZellPos In Array("B2", "B3", "B4", "B5", "B6", "B7", "B8", "B9", "B10")
Lspalte = Lspalte + 1
Cells(Lzeile, Lspalte) = ExecuteExcel4Macro("'C:\Temp\" & "[" & DateiName & "]Tabelle1" & "'!" & Range("" & ZellPos).Address(, , xlR1C1))
Next ZellPos
Lspalte = 0
Lzeile = Lzeile + 1
End If
End If
DateiName = Dir
Loop
Call EventsOn
End Sub

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

allerdings keine zeitmessungen durchgefuehrt,eventuell ist es von der laufzeit her sinnvoller die dateien zu oeffnen,wobei ja 12 zellen nicht die welt sind :-))