Anzeige
Archiv - Navigation
1232to1236
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

Tabelle auf Desktop kopieren

Tabelle auf Desktop kopieren
Wolfgang
Hallo,
mit nachfolgendem Code würde ich gerne erreichen, dass aus einer Mappe ein bestimmtes Tabellenblatt "Daten" auf Schaltflächendruck a.d. Desktop kopiert wird. Außer Zeile 1 (Überschriften) sollten in allen anderen Zeilen die Inhalte -nicht Format und Pulldowns, Zeilenumbrüche etc.- gelöscht werden (in der Kopie, nicht im Original). Wie müßte ich den Code umstellen, das zu erreichen und auch die Kopie als xlsx abgespeichert zu bekommen ? - Danke schon jetzt für die Rückmeldungen.
Gruß - Wolfgang

Sub Melden()
Dim wb As Workbook, wbneu As Workbook
Dim sPfadNeu As String
Set wb = ThisWorkbook
sPfadNeu = VBA.Environ("Userprofile") & "\Desktop\" 'ggf. Anpassen
'   sPfadNeu = "C:\Dokumente und Einstellungen\"& VBA.Environ("Username") & "\Desktop\" 'ggf. _
Anpassen
Application.ScreenUpdating = False
ThisWorkbook.Sheets("Daten").Copy
Set wbneu = ActiveWorkbook
wb.Activate
Application.DisplayAlerts = False
With wbneu
.SaveAs Filename:=sPfadNeu & "Finder " & Format(Now, "YYYY-MM-DD") & ".xls", _
FileFormat:=xlNormal, _
CreateBackup:=False, AddToMRU:=True 'wofür ist das gut?
'wie kann ich hier die Inhalte ab A2 löschen, aber nicht Formate?
.Save
.Close savechanges:=False
MsgBox "Eine Kopie der Datei wurde auf dem Desktop gespeichert!", vbInformation
End With
Application.ScreenUpdating = True
End Sub

5
Beiträge zum Forumthread
Beiträge zu diesem Forumthread

Betreff
Benutzer
Anzeige
AW: Tabelle auf Desktop kopieren
12.10.2011 21:21:36
Josef

Hallo Wolfgang,
probiere mal so.

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

Option Explicit

Sub Melden()
  Dim objWB As Workbook
  Dim strPath As String, strFile As String
  Dim strExt As String, lngFormat As Long
  
  On Error GoTo ErrExit
  tranquilize
  
  strPath = VBA.Environ("Userprofile") & "\Desktop\" 'ggf. Anpassen
  ' strPath = "C:\Dokumente und Einstellungen\"& VBA.Environ("Username") & "\Desktop\" 'ggf. _
    Anpassen

  
  strPath = IIf(Right(strPath, 1) = "\", strPath, strPath & "\")
  
  ThisWorkbook.Sheets("Daten").Copy
  
  Set objWB = ActiveWorkbook
  
  With objWB
    
    With .Sheets(1)
      .UsedRange.Offset(1, 0).ClearContents
    End With
    
    getFileExtAndFormat objWB, strExt, lngFormat
    
    strFile = strPath & "Finder " & Format(Now, "YYYY-MM-DD") & strExt
    
    .SaveAs Filename:=strFile, FileFormat:=lngFormat
    
    .Close
    
  End With
  
  MsgBox "Eine Kopie der Datei wurde auf dem Desktop gespeichert!", vbInformation
  
  ErrExit:
  tranquilize True
  Set objWB = Nothing
End Sub



Public Sub tranquilize(Optional ByVal Modus As Boolean = False)
  Static lngCalc As Long
  
  With Application
    .ScreenUpdating = Modus
    .EnableEvents = Modus
    .DisplayAlerts = Modus
    .EnableCancelKey = IIf(Modus, 1, 0)
    If Not Modus Then lngCalc = .Calculation
    If Modus And lngCalc = 0 Then lngCalc = -4105
    .Calculation = IIf(Modus, lngCalc, -4135)
    .Cursor = IIf(Modus, -4143, 2)
  End With
  
  If Modus Then
    With Err
      If .Number <> 0 Then
        MsgBox IIf(Erl, vbLf & "Fehler in Zeile:" & vbTab & Erl & vbLf & vbLf, "") & _
          "Fehlernummer:" & vbTab & .Number & vbLf & vbLf & "Beschreibung:" & vbLf & _
          .Description, vbExclamation, "Fehler"
      End If
      .Clear
    End With
  End If
End Sub


Function getFileExtAndFormat(ByRef WB As Workbook, ByRef strExt As String, ByRef lngFormat As Long)
  With WB
    If Val(Application.Version) < 12 Then
      strExt = ".xls": lngFormat = -4143
    Else
      Select Case WB.FileFormat
        Case 51: strExt = ".xlsx": lngFormat = 51
        Case 52:
          If .HasVBProject Then
            strExt = ".xlsm": lngFormat = 52
          Else
            strExt = ".xlsx": lngFormat = 51
          End If
        Case 56: strExt = ".xls": lngFormat = 56
        Case Else: strExt = ".xlsb": lngFormat = 50
      End Select
    End If
  End With
End Function



« Gruß Sepp »

Anzeige
Tausend Dank, Josef!!!
13.10.2011 05:58:32
Wolfgang
Hallo Josef,
recht herzlichen Dank für Deine Rückmeldung und Erstellung/Überlassung des Codes. Ich habe ihn soeben "eingebaut" und er läuft taddellos. Hab auch hierfür meinen herzlichen Dank. Ich freue mich sehr!
Gruß - Wolfgang
eine Frage noch
13.10.2011 19:59:28
Wolfgang
Hallo Josef,
mir fiel auf, dass beim Kopieren der Tabelle der Cursor bzw. auch die Scrollleiste sich in Bereichen wie A150 befinden können. Gäbe es evtl. eine Ergänzungsmöglichkeit in Deinem Code, dass Cursor bzw. auch Scrollleiste quasi auf Null bzw. A1 in der kopierten Tabelle eingestellt werden? Danke schon jetzt für Deine Rückmeldung.
Gruß - Wolfgang
Anzeige
AW: eine Frage noch
13.10.2011 20:45:47
Josef

Hallo Wolfgang.
ergänze die With-Anweisung.

With .Sheets(1)
  .UsedRange.Offset(1, 0).ClearContents
  Application.Goto .Range("A1"), True
End With



« Gruß Sepp »

Anzeige
erneut Tausend Dank!!
13.10.2011 21:13:17
Wolfgang
Hallo Josef,
erneut herzlichen Dank für Deine Rückmeldung und die Ergänzungen zum Code. Habe sie direkt eingebaut und es klappt wunderbar. Nochmals Danke!!
Gruß - Wolfgang

38 Forumthreads zu ähnlichen Themen

Anzeige
Anzeige
Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige
Anzeige
Anzeige