Excel Arbeitsblatt speichern

Dieses Thema Excel Arbeitsblatt speichern im Forum "Microsoft Office Suite" wurde erstellt von panscher, 18. Nov. 2006.

Thema: Excel Arbeitsblatt speichern Hallo, ich benötige ein Makro, das mir einen bestimmten Bereich eines Tabellenblatt (A1:M35) in den Ordner c:\test...

  1. Hallo,

    ich benötige ein Makro, das mir einen bestimmten Bereich eines Tabellenblatt (A1:M35) in den Ordner c:\test speichert. Der Dateinamen soll immer der Tabelleblattnamen sein.
    Dieser Tabelleblattname ist aber immer unterschiedlich, da ich ihn bereits über ein Makro umbennen.

    Martin
     
  2. Hallo panscher,

    dann probier mal da folgende Makro aus. die konstanten für Zielpfad und Bereich bitte vorher anpassen (siehe Makro <<< A N P A S S E N >>>).

    Der Dateiname der Zieldatei ist der Blattname + _yyyymmddhhnn, um den dateinamen eindeutig zu machen. Wenn  _yyyymmddhhnn stört, sag kurz Bescheid.

    Gruß Matjes :)
    Code:
    Option Explicit
    
    Sub Excet_BereichInNeueDateiKopieren()
    
     ->fest definierter Bereich
     -><<< A N P A S S E N >>>
      Const cBereich = B5: F7
      Const cZielPfad = d:\Test
     -><<< A N P A S S E N   E N D E >>>
    
      Dim ws As Worksheet, wb As Workbook, r As Range
      
      Dim sBlattname As String
      Dim lZeileBerAnf As Long, lSpalteBerAnf As Long
      Dim lZeileBerEnd As Long, lSpalteBerEnd As Long
      Dim sDateinameFull As String
      Dim x As Long, lRows As Long, lCols As Long
      
     ->aktive Mappe und Blatt setzen
      Set ws = ActiveSheet
      Set wb = ActiveWorkbook
      
     ->*** Blattname
      sBlattname = ws.Name
     ->ggf. hier noch eine Prüfung auf zulässige Zeichen für Dateinamen einfügen
     ->z.B. > ist im Blattnamen erlaubt, aber nicht im Dateinamen
      
     ->*** Bereich: erste und letzte Zeile/Spalte bestimmen
      Set r = ws.Range(cBereich)
      lZeileBerAnf = r.Row
      lSpalteBerAnf = r.Column
      lZeileBerEnd = r.Row + r.Rows.Count - 1
      lSpalteBerEnd = r.Column + r.Columns.Count - 1
      
     ->*** Datei-Kopie erstellen
     ->Pruefen, ob Zielpfad existiert
      If Dir(cZielPfad, vbDirectory) =  Then
        MsgBox Zielpfad  & cZielPfad &  existiert nicht.
        GoTo AUFRAEUMEN
      End If
      
     ->*** vollen Dateinamen zusammenstellen
     ->damit die Datei eindeutig ist wird das Datum/zeit im Dateinamen verwendet
      sDateinameFull = _
        cZielPfad & Application.PathSeparator & _
        sBlattname & Format(Now(), _yyyymmddhhnnss) & .xls
      
     ->*** Datei-Kopie unter neuem Namen anlegen
      On Error Resume Next
      wb.SaveCopyAs FileName:=sDateinameFull
      If Err.Number <> 0 Then
        Err.Clear
        MsgBox _
          Datei konnte nicht erstellt werden. & vbLf & _
          sDateinameFull & vbLf & vbLf & _
          Prüfen Sie den Blattnamen auf unzulässige Zeichen für dateinamen.
        On Error GoTo 0
        GoTo AUFRAEUMEN
      End If
      On Error GoTo 0
      
     ->*** Datei-Kopie öffnen
      Set wb = Workbooks.Open(FileName:=sDateinameFull)
      
     ->*** alle Blätter ausser dem betreffenden löschen
      Application.DisplayAlerts = False
      For x = wb.Worksheets.Count To 1 Step -1
        If wb.Worksheets(x).Name = sBlattname Then
          Set ws = wb.Worksheets(x)
        Else
          wb.Worksheets(x).Delete
        End If
      Next
      Application.DisplayAlerts = True
      
     ->*** alle Zeile/Spalten ausserhalb des Bereiches löschen
     ->Zeilen und Spaltenanzahl bestimmen
      With ws.UsedRange
        lRows = .Row + .Rows.Count - 1
        lCols = .Column + .Columns.Count - 1
      End With
     ->Zeilen unterhalb Bereich löschen
      If lRows > lZeileBerEnd Then
        ws.Rows(lZeileBerEnd + 1 & : & lRows).Delete
      End If
     ->Zeilen oberhalb vom Bereich löschen
      If lZeileBerAnf > 1 Then
        ws.Rows(1 & : & lZeileBerAnf - 1).Delete
      End If
     ->Spalten rechts vom Bereich löschen
      If lCols > lSpalteBerEnd Then
        MsgBox ColLetterToColNo(lSpalteBerEnd + 1) & : & ColLetterToColNo(lCols)
        ws.Columns(ColLetterToColNo(lSpalteBerEnd + 1) & : & _
                   ColLetterToColNo(lCols)).Delete
      End If
     ->Spalten links vom Bereich löschen
      If lSpalteBerAnf > 1 Then
        ws.Columns(A: & ColLetterToColNo(lSpalteBerAnf - 1)).Delete
      End If
    
     ->*** Datei Speichern und schliessen
      wb.Close SaveChanges:=True
      
    AUFRAEUMEN:
      Set wb = Nothing: Set ws = Nothing: Set r = Nothing
    End Sub
    
    '*******************************************************************
    Private Function ColLetterToColNo(lCol As Long) As String
      Dim s As String
      s = Columns(lCol).Address(False, False)
      ColLetterToColNo = Left(s, InStr(1, s, :) - 1)
    End Function
     
  3. Hallo,

    das Makro funktioniert soweit, aber leider gibts ein paar Probleme.

    1. Das speichern in den Ordner funktioniert soweit, nur kommt immer eine Mircosoft Excel Fenster hoch in dem L:M steht.

    2. Nach dem speichern fehlt mein Verknüfung zu einer anderen Datei.

    3. Es wäre toll, wenn Du die Uhrzeit im Dateiname noch weg machen könntest.

    Danke
    Martin
     
  4. Hallo Martin,

    zu 1)
    ist eine Ausgabe zu Testzwecken - jetzt entfernt

    zu 3)
    Dateiname wird jetzt aus Blattname + .xls gebildet
    (eine eventuell bereits vorhandene Datei gleichen Namens wird überschrieben)

    zu 2)
    wenn die in einer Zelle liegt, die innerhalb des Bereiches liegt, sollte das eigentlich nicht der fall sein. Kannst du mir ein Beispiel schicken ?

    Ein weitere Test wäre, alles von Hand nachzuvollziehen, was das Makro macht, und dann zuschauen, wann die Verknüpfung verschwindet.

    Gruß Matjes :)
    Code:
    Option Explicit
    
    Sub Excet_BereichInNeueDateiKopieren2()
    
     ->fest definierter Bereich
     -><<< A N P A S S E N >>>
      Const cBereich = B5: F7
      Const cZielPfad = d:\Test
     -><<< A N P A S S E N   E N D E >>>
    
      Dim ws As Worksheet, wb As Workbook, r As Range
      
      Dim sBlattname As String
      Dim lZeileBerAnf As Long, lSpalteBerAnf As Long
      Dim lZeileBerEnd As Long, lSpalteBerEnd As Long
      Dim sDateinameFull As String
      Dim x As Long, lRows As Long, lCols As Long
      
     ->aktive Mappe und Blatt setzen
      Set ws = ActiveSheet
      Set wb = ActiveWorkbook
      
     ->*** Blattname
      sBlattname = ws.Name
     ->ggf. hier noch eine Prüfung auf zulässige Zeichen für Dateinamen einfügen
     ->z.B. > ist im Blattnamen erlaubt, aber nicht im Dateinamen
      
     ->*** Bereich: erste und letzte Zeile/Spalte bestimmen
      Set r = ws.Range(cBereich)
      lZeileBerAnf = r.Row
      lSpalteBerAnf = r.Column
      lZeileBerEnd = r.Row + r.Rows.Count - 1
      lSpalteBerEnd = r.Column + r.Columns.Count - 1
      
     ->*** Datei-Kopie erstellen
     ->Pruefen, ob Zielpfad existiert
      If Dir(cZielPfad, vbDirectory) =  Then
        MsgBox Zielpfad  & cZielPfad &  existiert nicht.
        GoTo AUFRAEUMEN
      End If
      
     ->*** vollen Dateinamen zusammenstellen
      sDateinameFull = cZielPfad & Application.PathSeparator & sBlattname & .xls
      
     ->*** Datei-Kopie unter neuem Namen anlegen
     ->*** (alte wird ggf. überschrieben)
      On Error Resume Next
      Application.DisplayAlerts = False
      wb.SaveCopyAs FileName:=sDateinameFull
      Application.DisplayAlerts = True
      If Err.Number <> 0 Then
        Err.Clear
        MsgBox _
          Datei konnte nicht erstellt werden. & vbLf & _
          sDateinameFull & vbLf & vbLf & _
          Prüfen Sie den Blattnamen auf unzulässige Zeichen für dateinamen.
        On Error GoTo 0
        GoTo AUFRAEUMEN
      End If
      On Error GoTo 0
      
     ->*** Datei-Kopie öffnen
      Set wb = Workbooks.Open(FileName:=sDateinameFull)
      
     ->*** alle Blätter ausser dem betreffenden löschen
      Application.DisplayAlerts = False
      For x = wb.Worksheets.Count To 1 Step -1
        If wb.Worksheets(x).Name = sBlattname Then
          Set ws = wb.Worksheets(x)
        Else
          wb.Worksheets(x).Delete
        End If
      Next
      Application.DisplayAlerts = True
      
     ->*** alle Zeile/Spalten ausserhalb des Bereiches löschen
     ->Zeilen und Spaltenanzahl bestimmen
      With ws.UsedRange
        lRows = .Row + .Rows.Count - 1
        lCols = .Column + .Columns.Count - 1
      End With
     ->Zeilen unterhalb Bereich löschen
      If lRows > lZeileBerEnd Then
        ws.Rows(lZeileBerEnd + 1 & : & lRows).Delete
      End If
     ->Zeilen oberhalb vom Bereich löschen
      If lZeileBerAnf > 1 Then
        ws.Rows(1 & : & lZeileBerAnf - 1).Delete
      End If
     ->Spalten rechts vom Bereich löschen
      If lCols > lSpalteBerEnd Then
        ws.Columns(ColLetterToColNo(lSpalteBerEnd + 1) & : & _
                   ColLetterToColNo(lCols)).Delete
      End If
     ->Spalten links vom Bereich löschen
      If lSpalteBerAnf > 1 Then
        ws.Columns(A: & ColLetterToColNo(lSpalteBerAnf - 1)).Delete
      End If
    
     ->*** Datei Speichern und schliessen
      wb.Close SaveChanges:=True
      
    AUFRAEUMEN:
      Set wb = Nothing: Set ws = Nothing: Set r = Nothing
    End Sub
    
    '*******************************************************************
    Private Function ColLetterToColNo(lCol As Long) As String
      Dim s As String
      s = Columns(lCol).Address(False, False)
      ColLetterToColNo = Left(s, InStr(1, s, :) - 1)
    End Function
    a
    a)
     
  5. Hallo Matjes,

    ich mal wieder.

    Für mich ist der erste Code interessant.

    Kann er so umgewandelt werden, dass statt des Bereiches die gesamte Datei kopiert wird ?

    Ich würde mich freuen von dir zuhören.

    Einstweilen herzlichen Dank

    MfG Odje
     
  6. Hallo nok106,

    jo das ist ganz einfach ;D

    du wirfst einfach die Zeilen ab
    Code:
    ->*** Datei-Kopie öffnen
    bis ausschließlich
    Code:
    AUFRAEUMEN:
    raus.

    Gruß Matjes :)
     
  7. Hallo Matjes,

    alles paletti  :1

    Gruß Odje
     
Die Seite wird geladen...

Excel Arbeitsblatt speichern - Ähnliche Themen

Forum Datum
Excel: Filtern aus mehreren Arbeitsblättern mit Ergebniss in einem neuen AB Windows XP Forum 30. Jan. 2008
Excel-Makro zum Speichern eines Arbeitsblattes Webentwicklung, Hosting & Programmierung 7. März 2005
Formatierung von Excel Arbeitsblättern Windows XP Forum 17. Feb. 2003
Excel-Feature gesucht Microsoft Office Suite 11. Okt. 2016
Excel Tabelle Werte zu ordnen Microsoft Office Suite 23. Sep. 2016