AW: Tabellen kopieren
14.06.2015 13:54:42
Sepp
Hallo chito,
dann so.
' **********************************************************************
' Modul: Modul1 Typ: Allgemeines Modul
' **********************************************************************
Option Explicit
Sub copySheet()
Dim objSh As Worksheet
Dim objWB As Workbook
Dim strFile As String
Dim lngCalc As Long
On Error GoTo ErrExit
With Application
.ScreenUpdating = False
.EnableEvents = False
lngCalc = .Calculation
.Calculation = -4135
.DisplayAlerts = False
End With
strFile = "E:/Forum/Test/Test.xlsx" 'Anpassen
Set objSh = ThisWorkbook.Sheets("Permission") 'Tabelle die kopiert werden soll - Name anpassen!
If SheetExistC(strFile, objSh.Name) Then
MsgBox "Die Tabelle '" & objSh.Name & "' ist in der Datei '" & strFile & "' bereits vorhanden!", vbInformation
Else
Set objWB = Workbooks.Open(strFile)
With objWB
objSh.Copy after:=.Sheets(.Sheets.Count)
.Close True
End With
MsgBox "Die Tabelle '" & objSh.Name & "' wurde erfolgreich in die Datei '" & strFile & "' kopiert!", vbInformation
End If
ErrExit:
With Err
If .Number <> 0 Then
MsgBox "Fehler in Prozedur:" & vbTab & "'copySheet'" & vbLf & String(60, "_") & _
vbLf & vbLf & IIf(Erl, "Fehler in Zeile:" & vbTab & Erl & vbLf & vbLf, "") & _
"Fehlernummer:" & vbTab & .Number & vbLf & vbLf & "Beschreibung:" & vbTab & _
.Description & vbLf, vbExclamation + vbMsgBoxSetForeground, _
"VBA - Fehler in Prozedur - copySheet"
.Clear
End If
End With
On Error GoTo 0
With Application
.ScreenUpdating = True
.EnableEvents = True
.Calculation = lngCalc
.DisplayAlerts = True
.StatusBar = False
End With
Set objWB = Nothing
Set objSh = Nothing
End Sub
Private Function SheetExistC(FileName As String, ByVal sheetName As String) As Boolean
Dim vntSheets As Variant, lngIndex As Long
vntSheets = GetSheetNames(FileName)
If IsArray(vntSheets) Then
SheetExistC = IsNumeric(Application.Match(sheetName, vntSheets, 0))
End If
End Function
Private Function GetSheetNames(ByVal FileName As String) As Variant
'original by Bob Phillips, adapted by j.ehrensberger
Dim objADO_Connection As Object, objADO_Catalog As Object, objADO_Tables As Object
Dim lngIndex As Long, intLength As Integer, intPos As Integer, intStart As Integer
Dim strConString As String, strTable As String
Dim vntTmp() As Variant
If Dir(FileName, vbNormal) = "" Then Exit Function
If Mid(FileName, InStrRev(FileName, ".") + 1) = "xls" Then
strConString = "Provider=Microsoft.Jet.OLEDB.4.0;" & "Extended Properties=Excel 8.0;" & _
"Data Source=" & FileName & ";"
ElseIf Mid(FileName, InStrRev(FileName, ".") + 1) Like "xls?" Then
strConString = "Provider=Microsoft.ACE.OLEDB.12.0;" & "Extended Properties=""Excel 12.0;HDR=YES"";" _
& "Data Source=" & FileName & ";"
Else
Exit Function
End If
Set objADO_Connection = CreateObject("ADODB.Connection")
objADO_Connection.Open strConString
Set objADO_Catalog = CreateObject("ADOX.Catalog")
Set objADO_Catalog.ActiveConnection = objADO_Connection
For Each objADO_Tables In objADO_Catalog.Tables
strTable = objADO_Tables.Name
intLength = Len(strTable)
intPos = 0
intStart = 1
'Worksheet name with embedded spaces enclosed by single quotes
If Left(strTable, 1) = "'" And Right(strTable, 1) = "'" Then
intPos = 1
intStart = 2
End If
'Worksheet names always end in the "$" character
If Mid$(strTable, intLength - intPos, 1) = "$" Then
Redim Preserve vntTmp(lngIndex)
vntTmp(lngIndex) = Mid$(strTable, intStart, intLength - (intStart + intPos))
lngIndex = lngIndex + 1
End If
Next objADO_Tables
If lngIndex > 0 Then GetSheetNames = vntTmp
objADO_Connection.Close
Set objADO_Catalog = Nothing
Set objADO_Connection = Nothing
End Function
Gruß Sepp