Tabellen kopieren

Informationen und Beispiele zu den hier genannten Dialog-Elementen:
MsgBox
Bild

Betrifft: Tabellen kopieren
von: chito
Geschrieben am: 13.06.2015 12:04:23

Hallo zusammen,
ich habe heute eine Frage, die für euch einfach aber für mich ein Problem darstellen. Ich möchte aus einer offenen Exceltabelle eine Mappe mit Namen Permission in eine geschlossene Datei kopieren, ja ich weiß das geht nicht, aber kann ich diese geschlossene Datei im Hintergrund öffnen, dann die Mappe kopieren und nach dem kopieren wieder schließen und wie stelle ich das an ?
für Hilfe bin ich sehr dankbar.
Gruß
chito

Bild

Betrifft: AW: Tabellen kopieren
von: Sepp
Geschrieben am: 13.06.2015 12:21:50
Hallo chito,
der Code gehört in ein allgemeines Modul in der Datei dessen Tabellenblatt kopiert und eingefügt werden soll.

' **********************************************************************
' Modul: Modul1 Typ: Allgemeines Modul
' **********************************************************************

Option Explicit

Sub copySheet()
  Dim objSh As Worksheet
  Dim objWB As Workbook
  
  Dim lngCalc As Long
  
  On Error GoTo ErrExit
  
  With Application
    .ScreenUpdating = False
    .EnableEvents = False
    lngCalc = .Calculation
    .Calculation = -4135
    .DisplayAlerts = False
  End With
  
  Set objSh = ThisWorkbook.Sheets("Permission") 'Tabelle die kopiert werden soll - Name anpassen!
  
  Set objWB = Workbooks.Open("C:/Pfad und Name der Datei in welche das Tabellenblatt eingefügt werden soll.xlsx") 'Anpassen
  
  With objWB
    objSh.Copy after:=.Sheets(.Sheets.Count)
    .Close True
  End With
  
  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


Gruß Sepp


Bild

Betrifft: AW: Tabellen kopieren - Zusatzfrage
von: WalterK
Geschrieben am: 13.06.2015 12:47:44
Hallo Sepp,
möchte mich kurz mit einer Zusatzfrage einklinken:
Wie müsste der Code geändert werden, damit in der Zieldatei das kopierte Blatt nicht mehr Permission heißt sondern der Blattname das aktuelle Datum und die aktuelle Zeit hat.
Besten Dank für die Hilfe, Servus Walter

Bild

Betrifft: AW: Tabellen kopieren - Zusatzfrage
von: Sepp
Geschrieben am: 13.06.2015 12:51:42
Hallo Walter,
diesen Teil anpassen.

With objWB
  objSh.Copy after:=.Sheets(.Sheets.Count)
  .Sheets(.Sheets.Count).Name = Format(Now(), "ddMMyyyy hhmmss")
  .Close True
End With

Gruß Sepp


Bild

Betrifft: Besten Dank Sepp. Servus Walter
von: WalterK
Geschrieben am: 13.06.2015 14:05:50


Bild

Betrifft: AW: Tabellen kopieren
von: chito
Geschrieben am: 13.06.2015 17:48:16
Dankeschön Sepp

Bild

Betrifft: AW: Tabellen kopieren
von: chito
Geschrieben am: 14.06.2015 13:30:53
Hallo Sepp,
eine Kleinigkeit fehlt mir noch.
wie muss der Code geändert werden wenn die zu kopierende Tabelle schon vorhanden ist ?
Gruß
chito

Bild

Betrifft: AW: Tabellen kopieren
von: Sepp
Geschrieben am: 14.06.2015 13:34:16
Hallo chito,
"wie muss der Code geändert werden wenn die zu kopierende Tabelle schon vorhanden ist ?"
Das hängt davon ab, was dann geschehen soll!

Gruß Sepp


Bild

Betrifft: AW: Tabellen kopieren
von: chito
Geschrieben am: 14.06.2015 13:45:04
Hi Sepp,
eigentlich soll dann nichts passieren und ganz normal in der Tabelle gearbeitet werden.
Gruß
chito

Bild

Betrifft: AW: Tabellen kopieren
von: Sepp
Geschrieben am: 14.06.2015 13:54:42
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


Bild

Betrifft: AW: Tabellen kopieren
von: chito
Geschrieben am: 14.06.2015 14:30:41
Hi Sepp,
vielen Dank so sollte es sein
Gruß
chito

 Bild

Beiträge aus den Excel-Beispielen zum Thema "Tabellen kopieren"