Gruppen

Top Gruppen: Windows 7; Windows Vista; Windows XP; Textverarbeitung; Excel; DSL; Internet Browser; E-Mail/Outlook
Betriebsysteme: Windows classik; Linux; BS-Sonstige
Software: Datenbanken; Bildbearbeitung; Audio/mp3/Video; Security/Viren; SW-Sonstige
Hardware: Mainboard/CPU; Grafikkarten; Peripherie; Laptop/Notebook; HW-Sonstiges
Netzwerk: Telefon,ISDN,Modem; W-Lan; NW-Sonstiges
Programmierung: PHP,ASP,Perl...; Java,C++...; Webseiten/HTML
Sonstiges: PC-Sonstiges; Plauderecke; SN Intern; Test

/ Forum / Tabellenkalkulation

Tabellenkalkulation

Fragevon andyamo vom 03.08.2022, 21:03 Options

VBA: Informationen mittels Makro aus anderen Dateien auslesen

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

Antwort schreiben

Antwort 1 von nighty vom 03.08.2022, 21:54 Options

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

Antwort 2 von nighty vom 04.08.2022, 08:22 Options

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 :-))

Hinweis

Diese Frage ist schon etwas älter, Sie können daher nicht mehr auf sie antworten. Sollte Ihre Frage noch nicht gelöst sein, stellen Sie einfach eine neue Frage im Forum..

Neue Einträge

Tipp einschicken

News einschicken