Live-Forum - Die aktuellen Beiträge
Datum
Titel
28.03.2024 21:12:36
28.03.2024 18:31:49
Anzeige
Archiv - Navigation
1428to1432
Aktuelles Verzeichnis
Verzeichnis Index
Übersicht Verzeichnisse
Vorheriger Thread
Rückwärts Blättern
Nächster Thread
Vorwärts blättern
Anzeige
HERBERS
Excel-Forum (Archiv)
20+ Jahre Excel-Kompetenz: Von Anwendern, für Anwender
Inhaltsverzeichnis

Tabellen kopieren

Tabellen kopieren
13.06.2015 12:04:23
chito

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

10
Beiträge zum Forumthread
Beiträge zu diesem Forumthread

Betreff
Datum
Anwender
Anzeige
AW: Tabellen kopieren
13.06.2015 12:21:50
Sepp
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

Anzeige
AW: Tabellen kopieren - Zusatzfrage
13.06.2015 12:47:44
WalterK
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

AW: Tabellen kopieren - Zusatzfrage
13.06.2015 12:51:42
Sepp
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

Anzeige
Besten Dank Sepp. Servus Walter
13.06.2015 14:05:50
WalterK

AW: Tabellen kopieren
13.06.2015 17:48:16
chito
Dankeschön Sepp

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

AW: Tabellen kopieren
14.06.2015 13:34:16
Sepp
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

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

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

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

Beliebteste Forumthreads (12 Monate)

Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige
Anzeige
Anzeige