AW: VBA Code zum Kopieren aus geschlossenen Dateien
13.07.2015 20:18:26
WalterK
Hallo Sepp, hier mein gesamter Code:
Option Explicit
Sub Import_XLS()
' 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
Dim arrStrings(3, 1) As Variant
Dim Intc As Integer
Dim strPath As String
Dim strFile As String
Dim strTab As String
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)
wsTemp.Range("A1").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
Public Function ExcelTable(ByRef Path As String, ByRef SourceRange As String) As Object
Dim SQL As String
Dim Con As String
SQL = "select * from [" & SourceRange & "]"
If Mid(Path, InStrRev(Path, ".") + 1) = "xls" Then
Con = "Provider=Microsoft.Jet.OLEDB.4.0;" _
& "Extended Properties=Excel 8.0;" _
& "Data Source=" & Path & ";"
ElseIf Mid(Path, InStrRev(Path, ".") + 1) Like "xls?" Then
Con = "Provider=Microsoft.ACE.OLEDB.12.0;" _
& "Extended Properties=""Excel 12.0;HDR=YES"";" _
& "Data Source=" & Path & ";"
Else
Exit Function
End If
Set ExcelTable = CreateObject("ADODB.Recordset")
ExcelTable.Open SQL, Con, 3, 1
End Function
Danke und Servus, Walter