Thema Datum  Von Nutzer Rating
Antwort
14.03.2019 09:34:51 Peter
NotSolved
14.03.2019 10:21:00 Flotter Feger
NotSolved
14.03.2019 10:33:41 Peter
NotSolved
14.03.2019 11:50:02 Andreas Nerling
NotSolved
14.03.2019 12:47:00 Peter
NotSolved
18.03.2019 08:47:59 Flotter Feger
NotSolved
20.03.2019 09:51:38 Peter
NotSolved
Blau Daten aus mehreren abgelegten Dateien auslesen
 20.03.2019 18:36:48 Flotter Feger
NotSolved
21.03.2019 08:08:01 Peter
*****
Solved

Ansicht des Beitrags:
Von:
Flotter Feger		 Datum:
20.03.2019 18:36:48		 Views:
773		 Rating:
     
Antwort:
  Ja
Thema:
Daten aus mehreren abgelegten Dateien auslesen

Hallo,

teste mal ...

Option Explicit

Public Sub Test()

Const FILE_PATH = "C:\Temp\" '<--- anpassen

Dim strFileName As String
Dim objSheet1 As Worksheet
Dim objSheet2 As Worksheet
Dim objWorkbook1 As Workbook
Dim objWorkbook2 As Workbook
Dim aLetzte As Long

On Error GoTo err_exit

Application.ScreenUpdating = False

strFileName = Dir$(FILE_PATH & "*.xls*")
Set objWorkbook2 = ThisWorkbook
Set objSheet2 = objWorkbook2.Worksheets("Tabelle1") '<--- Ziel anpassen
aLetzte = objSheet2.Cells(Rows.Count, 1).End(xlUp).Row + 1

Do While strFileName <> ""
    Set objWorkbook1 = Workbooks.Open(Filename:= _
            FILE_PATH & strFileName, UpdateLinks:=0)
        
    '*** Hier dein Code für das Kopieren ***'
    Set objSheet1 = objWorkbook1.Worksheets("Tabelle1") '<--- Quelle anpassen
    objSheet2.Cells(aLetzte, 1).Value = objSheet1.Range("B4").Text
    objSheet2.Cells(aLetzte, 2).Value = objSheet1.Range("B12").Text
    objSheet2.Cells(aLetzte, 3).Value = objSheet1.Range("B13").Text
    objSheet2.Cells(aLetzte, 4).Value = objSheet1.Range("B14").Text
    objSheet2.Cells(aLetzte, 5).Value = objSheet1.Range("B15").Text
    'usw...
    
    aLetzte = aLetzte + 1
    objWorkbook1.Close SaveChanges:=False  ' nicht Speichern und schließen
    strFileName = Dir$()
Loop

err_exit:

Set objWorkbook1 = Nothing
Set objWorkbook2 = Nothing
Set objSheet1 = Nothing
Set objSheet1 = Nothing

Application.ScreenUpdating = True

If Err.Number <> 0 Then MsgBox "Fehler: " & _
    Err.Number & " " & Err.Description
End Sub

Gruß Sabina

Ihre Antwort
  • Bitte beschreiben Sie Ihr Problem möglichst ausführlich. (Wichtige Info z.B.: Office Version, Betriebssystem, Wo genau kommen Sie nicht weiter)
  • Bitte helfen Sie ebenfalls wenn Ihnen geholfen werden konnte und markieren Sie Ihre Anfrage als erledigt (Klick auf Häckchen)
  • Bei Crossposting, entsprechende Links auf andere Forenbeiträge beifügen / nachtragen
  • Codeschnipsel am besten über den Code-Button im Text-Editor einfügen
  • Die Angabe der Emailadresse ist freiwillig und wird nur verwendet, um Sie bei Antworten auf Ihren Beitrag zu benachrichtigen
Thema: Name: Email:



  • Bitte beschreiben Sie Ihr Problem möglichst ausführlich. (Wichtige Info z.B.: Office Version, Betriebssystem, Wo genau kommen Sie nicht weiter)
  • Bitte helfen Sie ebenfalls wenn Ihnen geholfen werden konnte und markieren Sie Ihre Anfrage als erledigt (Klick auf Häckchen)
  • Bei Crossposting, entsprechende Links auf andere Forenbeiträge beifügen / nachtragen
  • Codeschnipsel am besten über den Code-Button im Text-Editor einfügen
  • Die Angabe der Emailadresse ist freiwillig und wird nur verwendet, um Sie bei Antworten auf Ihren Beitrag zu benachrichtigen

Thema Datum  Von Nutzer Rating
Antwort
14.03.2019 09:34:51 Peter
NotSolved
14.03.2019 10:21:00 Flotter Feger
NotSolved
14.03.2019 10:33:41 Peter
NotSolved
14.03.2019 11:50:02 Andreas Nerling
NotSolved
14.03.2019 12:47:00 Peter
NotSolved
18.03.2019 08:47:59 Flotter Feger
NotSolved
20.03.2019 09:51:38 Peter
NotSolved
Blau Daten aus mehreren abgelegten Dateien auslesen
 20.03.2019 18:36:48 Flotter Feger
NotSolved
21.03.2019 08:08:01 Peter
*****
Solved