VBA - xls-Dateien einlesen - nochmals Codeergänzun

Bild

Betrifft: VBA - xls-Dateien einlesen - nochmals Codeergänzun
von: WalterK
Geschrieben am: 15.07.2015 21:12:31

Hallo,
der folgende Code liest 4 xls-Dateien in vorhandene Blätter ein. Funktioniert dank Sepps Hilfe bestens. Beim Testen sind mir noch zwei Dinge eingefallen die ich selbst einfach nicht umsetzen kann:
1.) Falls eine der 4 xls-Dateien nicht vorhanden ist soll der Code einfach mit dem nächsten Next weitermachen.
2.) Am Schluss sollen alle 4 xls-Dateien gelöscht werden.
Hier der Code:


Option Explicit
Sub Import_XLS()
  Dim arrStrings(3, 1) As Variant
  Dim Intc As Integer
  Dim strPath As String
  Dim strFile As String
  Dim strTab As String
  Dim lngI As Long
  
  ' Sheets("Infofenster").Select
  Application.ScreenUpdating = False
  
  With Application
    .ScreenUpdating = False
    .EnableEvents = False
    .DisplayAlerts = False
    .Calculation = xlCalculationManual
    .Cursor = xlWait
  End With
  
  Sheets("A_Xls_Export").Range("A:BZ").ClearContents
  Sheets("B_Xls_Export").Range("A:BZ").ClearContents
  Sheets("C_Xls_Export").Range("A:BZ").ClearContents
  Sheets("D_Xls_Export").Range("A:BZ").ClearContents
  
  arrStrings(0, 0) = "A_Xls_Export"
  arrStrings(0, 1) = "A_Xls_Export.xls"
  
  arrStrings(1, 0) = "B_Xls_Export"
  arrStrings(1, 1) = "B_Xls_Export.xls"
  
  arrStrings(2, 0) = "C_Xls_Export"
  arrStrings(2, 1) = "C_Xls_Export.xls"
  
  arrStrings(3, 0) = "D_Xls_Export"
  arrStrings(3, 1) = "D_Xls_Export.xls"
  
  For Intc = 0 To UBound(arrStrings)
    Sheets(arrStrings(Intc, 0)).Range("A1:IV65536").ClearContents
    
    Dim IntcPfad As String
    Dim IntcDateiname As String
    Dim IntcBlatt As String
    Dim IntcZellen As String
    
    Dim wsTemp As Worksheet
    Set wsTemp = ActiveWorkbook.Worksheets.Add(After:=ActiveWorkbook.Worksheets( _
      ActiveWorkbook.Worksheets.Count))
    wsTemp.Name = "TemporäresBlatt"
    IntcPfad = "D:\___XLS_EXPORTE\" 'Datenarbeitsmappe
    IntcDateiname = arrStrings(Intc, 1)
    IntcBlatt = "Sheet0"
    
    Dim objADO As Object
    Dim strFileGesamt As String, strRef2 As String
    
    strFileGesamt = IntcPfad & IntcDateiname
    
    strRef2 = "Sheet0$A:Z" 'normale Bereichsangabe unbedingt MIT Tabellenname & $-Zeichen
    
    Set objADO = ExcelTable(strFileGesamt, strRef2)
    'Spaltennamen!
    For lngI = 1 To objADO.Fields.Count
      wsTemp.Cells(1, lngI) = Replace(objADO.Fields(lngI - 1).Name, "#", ".")
    Next
    wsTemp.Range("A2").CopyFromRecordset objADO
    objADO.Close
    
    
    If wsTemp.Range("F1") = "MitgliedNEU" Then
      wsTemp.Columns("F:G").Delete
    End If
    If wsTemp.Range("H1") = "Adresse2" Then
      wsTemp.Columns("H:H").Delete
    End If
    
    wsTemp.Columns("A:Z").Copy
    Worksheets(arrStrings(Intc, 0)).Range("A1").PasteSpecial (xlPasteAll)
    
    wsTemp.Delete
    
  Next
  
  With Application
    .StatusBar = False
    .ScreenUpdating = True
    .EnableEvents = True
    .DisplayAlerts = True
    .Calculation = xlCalculationAutomatic
    .Cursor = xlDefault
  End With
  
End Sub

Besten Dank für die Hilfe, Servus Walter

Bild

Betrifft: AW: VBA - xls-Dateien einlesen - nochmals Codeergänzun
von: Sepp
Geschrieben am: 15.07.2015 22:21:03
Hallo Walter,
ungetestet. (hab den Code ein bisschen aufgeräumt!)

Sub Import_XLS()
  'Deklarationen gehören an den Beginn der Prozedur!
  Dim wsTemp As Worksheet
  Dim objADO As Object
  Dim arrStrings(3, 1) As Variant
  Dim strPath As String, strBlatt As String
  Dim strFileGesamt As String, strRef2 As String
  Dim lngI As Long, Intc As Integer
  
  ' Sheets("Infofenster").Select
  
  With Application
    .ScreenUpdating = False
    .EnableEvents = False
    .DisplayAlerts = False
    .Calculation = xlCalculationManual
    .Cursor = xlWait
  End With
  
  arrStrings(0, 0) = "A_Xls_Export"
  arrStrings(0, 1) = "A_Xls_Export.xls"
  
  arrStrings(1, 0) = "B_Xls_Export"
  arrStrings(1, 1) = "B_Xls_Export.xls"
  
  arrStrings(2, 0) = "C_Xls_Export"
  arrStrings(2, 1) = "C_Xls_Export.xls"
  
  arrStrings(3, 0) = "D_Xls_Export"
  arrStrings(3, 1) = "D_Xls_Export.xls"
  
  strRef2 = "Sheet0$A:Z" 'normale Bereichsangabe unbedingt MIT Tabellenname & $-Zeichen
  strPath = "D:\___XLS_EXPORTE\" 'Datenarbeitsmappe
  strBlatt = "Sheet0"
  
  For Intc = 0 To UBound(arrStrings)
    strFileGesamt = strPath & arrStrings(Intc, 1)
    Sheets(arrStrings(Intc, 0)).UsedRange.ClearContents
    
    If Dir(strFileGesamt, vbNormal) <> "" Then
      Set wsTemp = ActiveWorkbook.Worksheets.Add(After:=ActiveWorkbook.Worksheets( _
        ActiveWorkbook.Worksheets.Count))
      wsTemp.Name = "TemporäresBlatt"
      
      Set objADO = ExcelTable(strFileGesamt, strRef2)
      'Spaltennamen!
      For lngI = 1 To objADO.Fields.Count
        wsTemp.Cells(1, lngI) = Replace(objADO.Fields(lngI - 1).Name, "#", ".")
      Next
      wsTemp.Range("A2").CopyFromRecordset objADO
      objADO.Close
      
      If wsTemp.Range("F1") = "MitgliedNEU" Then
        wsTemp.Columns("F:G").Delete
      End If
      If wsTemp.Range("H1") = "Adresse2" Then
        wsTemp.Columns("H:H").Delete
      End If
      
      wsTemp.Columns("A:Z").Copy Worksheets(arrStrings(Intc, 0)).Range("A1")
      
      wsTemp.Delete
      Kill strFileGesamt
    End If
  Next
  
  With Application
    .StatusBar = False
    .ScreenUpdating = True
    .EnableEvents = True
    .DisplayAlerts = True
    .Calculation = xlCalculationAutomatic
    .Cursor = xlDefault
  End With
  
  Set objADO = Nothing
  Set wsTemp = Nothing
End Sub


Gruß Sepp


Bild

Betrifft: AW: VBA - xls-Dateien einlesen - nochmals Codeergänzun
von: WalterK
Geschrieben am: 15.07.2015 22:46:17
Hallo Sepp,
besten Dank, Punkt 1 funktioniert jedenfalls bestens.
Bei der Zeile Kill wird die folgende Fehlermeldung angezeigt:
Laufzeitfehler 70: Zugriff verweigert
Vielleicht gibt es hier auch noch eine Lösung?
Danke und Servus, Walter

Bild

Betrifft: AW: VBA - xls-Dateien einlesen - nochmals Codeergänzun
von: Sepp
Geschrieben am: 15.07.2015 22:56:00
Hallo Walter,
dann hast du die Datei offen!

Gruß Sepp


Bild

Betrifft: AW: VBA - xls-Dateien einlesen - nochmals Codeergänzun
von: WalterK
Geschrieben am: 15.07.2015 23:07:43
Hallo Sepp,
nein, es ist nur die eine Datei mit dem Einlesecode offen.
Servus, Walter

Bild

Betrifft: AW: VBA - xls-Dateien einlesen - nochmals Codeergänzun
von: Sepp
Geschrieben am: 15.07.2015 23:20:07
Hallo Walter,
probier es mal so.

' **********************************************************************
' Modul: Modul2 Typ: Allgemeines Modul
' **********************************************************************

Option Explicit

Sub Import_XLS()
  'Deklarationen gehören an den Beginn der Prozedur!
  Dim wsTemp As Worksheet
  Dim objADO As Object
  Dim arrStrings(3, 1) As Variant
  Dim strPath As String, strBlatt As String
  Dim strFileGesamt As String, strRef2 As String
  Dim lngI As Long, Intc As Integer
  
  ' Sheets("Infofenster").Select
  
  With Application
    .ScreenUpdating = False
    .EnableEvents = False
    .DisplayAlerts = False
    .Calculation = xlCalculationManual
    .Cursor = xlWait
  End With
  
  arrStrings(0, 0) = "A_Xls_Export"
  arrStrings(0, 1) = "A_Xls_Export.xls"
  
  arrStrings(1, 0) = "B_Xls_Export"
  arrStrings(1, 1) = "B_Xls_Export.xls"
  
  arrStrings(2, 0) = "C_Xls_Export"
  arrStrings(2, 1) = "C_Xls_Export.xls"
  
  arrStrings(3, 0) = "D_Xls_Export"
  arrStrings(3, 1) = "D_Xls_Export.xls"
  
  strRef2 = "Sheet0$A:Z" 'normale Bereichsangabe unbedingt MIT Tabellenname & $-Zeichen
  strPath = "D:\___XLS_EXPORTE\" 'Datenarbeitsmappe
  strBlatt = "Sheet0"
  
  For Intc = 0 To UBound(arrStrings)
    strFileGesamt = strPath & arrStrings(Intc, 1)
    Sheets(arrStrings(Intc, 0)).UsedRange.ClearContents
    
    If Dir(strFileGesamt, vbNormal) <> "" Then
      Set wsTemp = ActiveWorkbook.Worksheets.Add(After:=ActiveWorkbook.Worksheets( _
        ActiveWorkbook.Worksheets.Count))
      wsTemp.Name = "TemporäresBlatt"
      
      Set objADO = ExcelTable(strFileGesamt, strRef2)
      'Spaltennamen!
      For lngI = 1 To objADO.Fields.Count
        wsTemp.Cells(1, lngI) = Replace(objADO.Fields(lngI - 1).Name, "#", ".")
      Next
      wsTemp.Range("A2").CopyFromRecordset objADO
      objADO.Close
      
      If wsTemp.Range("F1") = "MitgliedNEU" Then
        wsTemp.Columns("F:G").Delete
      End If
      If wsTemp.Range("H1") = "Adresse2" Then
        wsTemp.Columns("H:H").Delete
      End If
      
      wsTemp.Columns("A:Z").Copy Worksheets(arrStrings(Intc, 0)).Range("A1")
      
      wsTemp.Delete
      KillFile strFileGesamt
    End If
  Next
  
  With Application
    .StatusBar = False
    .ScreenUpdating = True
    .EnableEvents = True
    .DisplayAlerts = True
    .Calculation = xlCalculationAutomatic
    .Cursor = xlDefault
  End With
  
  Set objADO = Nothing
  Set wsTemp = Nothing
End Sub


Private Function KillFile(FileName As String, Optional Force As Boolean = True) As Long
  Dim objFSO As Object
  
  KillFile = -1
  
  On Error GoTo ErrExit
  
  Set objFSO = CreateObject("Scripting.FileSystemObject")
  
  objFSO.DeleteFile FileName, Force
  
  Exit Function
  
  ErrExit:
  KillFile = 0
End Function


Gruß Sepp


Bild

Betrifft: Hallo Sepp. Der Code läuft jetzt zwar ...
von: WalterK
Geschrieben am: 15.07.2015 23:52:13
.. durch, es werden die Dateien aber nicht gelöscht.
Danke und Servus, Walter

Bild

Betrifft: AW: Hallo Sepp. Der Code läuft jetzt zwar ...
von: Sepp
Geschrieben am: 16.07.2015 00:07:58
Hallo Walter,
jetzt aber! hab übersehen, das objADO noch existiert und deshalb der Zugriff auf die Datei logischerweise nicht möglich war.

Sub Import_XLS()
  'Deklarationen gehören an den Beginn der Prozedur!
  Dim wsTemp As Worksheet
  Dim objADO As Object
  Dim arrStrings(3, 1) As Variant
  Dim strPath As String, strBlatt As String
  Dim strFileGesamt As String, strRef2 As String
  Dim lngI As Long, Intc As Integer
  
  ' Sheets("Infofenster").Select
  On Error GoTo ErrExit
  With Application
    .ScreenUpdating = False
    .EnableEvents = False
    .DisplayAlerts = False
    .Calculation = xlCalculationManual
    .Cursor = xlWait
  End With
  
  arrStrings(0, 0) = "A_Xls_Export"
  arrStrings(0, 1) = "A_Xls_Export.xls"
  
  arrStrings(1, 0) = "B_Xls_Export"
  arrStrings(1, 1) = "B_Xls_Export.xls"
  
  arrStrings(2, 0) = "C_Xls_Export"
  arrStrings(2, 1) = "C_Xls_Export.xls"
  
  arrStrings(3, 0) = "D_Xls_Export"
  arrStrings(3, 1) = "D_Xls_Export.xls"
  
  strRef2 = "Sheet0$A:Z" 'normale Bereichsangabe unbedingt MIT Tabellenname & $-Zeichen
  strPath = "D:\___XLS_EXPORTE\" 'Datenarbeitsmappe
  strBlatt = "Sheet0"
  
  For Intc = 0 To UBound(arrStrings)
    strFileGesamt = strPath & arrStrings(Intc, 1)
    Sheets(arrStrings(Intc, 0)).UsedRange.ClearContents
    
    If Dir(strFileGesamt, vbNormal) <> "" Then
      Set wsTemp = ActiveWorkbook.Worksheets.Add(After:=ActiveWorkbook.Worksheets( _
        ActiveWorkbook.Worksheets.Count))
      wsTemp.Name = "TemporäresBlatt"
      
      Set objADO = ExcelTable(strFileGesamt, strRef2)
      'Spaltennamen!
      For lngI = 1 To objADO.Fields.Count
        wsTemp.Cells(1, lngI) = Replace(objADO.Fields(lngI - 1).Name, "#", ".")
      Next
      wsTemp.Range("A2").CopyFromRecordset objADO
      objADO.Close
      Set objADO = Nothing
      
      If wsTemp.Range("F1") = "MitgliedNEU" Then
        wsTemp.Columns("F:G").Delete
      End If
      If wsTemp.Range("H1") = "Adresse2" Then
        wsTemp.Columns("H:H").Delete
      End If
      
      wsTemp.Columns("A:Z").Copy Worksheets(arrStrings(Intc, 0)).Range("A1")
      
      wsTemp.Delete
      Kill strFileGesamt
    End If
  Next
  
  ErrExit:
  With Application
    .StatusBar = False
    .ScreenUpdating = True
    .EnableEvents = True
    .DisplayAlerts = True
    .Calculation = xlCalculationAutomatic
    .Cursor = xlDefault
  End With
  
  Set objADO = Nothing
  Set wsTemp = Nothing
End Sub


Gruß Sepp


Bild

Betrifft: Einfach Toll. Ich bin begeistert ...
von: WalterK
Geschrieben am: 16.07.2015 00:19:35
... von Deinem ExcelWissen.
Besten Dank und gute Nacht, Walter

 Bild

Beiträge aus den Excel-Beispielen zum Thema "VBA - xls-Dateien einlesen - nochmals Codeergänzun"