VBA Problem Datenspeicherung

Hallo zusammen,
Bin VBA Neuling und schlage mich seit Stunden vergebens mit folgenden Problem rum.
Habe Schaltfäche die folgenden Automatismus machen soll:
- Abfrage wie gleich neu geöffnete Datei (Datei2) heissen soll
- falls Name in voegegebenem Ordner schon vorhanden box zum Überschreiben bzw. neue namenseingabe einblenden
- (Datei1)Daten aus den Zellen B9 bis B1500 kopieren
- neue Exceldatei (Datei2) öffnen und daten dort in B9 bis B1500 kopieren
- wechsel zu datei1
- Daten aus anderem Arbeitsblatt Zelle B1 bis b8 kopieren
- wechsel zu datei2 und daten dort in b1 bis b8 einfügen
- Datei 2 unter (in Punkt1) angegebenem namen speichern
Hoffe ihr lönnt mir helfen, als anfänger hat man bei sowas eher schlehcte karten.
Vielen Dank im Voraus!

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Hallo Ludes,
das geht zB. so.
' **********************************************************************
' Modul: Modul2 Typ: Allgemeines Modul
' **********************************************************************

Option Explicit

Sub DateiNeu()
Dim strFile As String, strSheet As String
Dim objWb As Workbook

On Error GoTo ErrExit
GMS

strFile = Application.GetSaveAsFilename( _
    InitialFileName:="F:\Temp\test.xls", _
    filefilter:="Excel Dateien (*.xls; *.xlsx; *.xlsm)," & _
    "*.xls; *.xlsx; *.xlsm")

If strFile = "Falsch" Then GoTo ErrExit

strSheet = "Neue Tabelle" 'Name des Tabellenblattes in der neuen Datei - Anpassen!

Set objWb = Workbooks.Add(xlWBATWorksheet)

objWb.Sheets(1).Name = strSheet

With ThisWorkbook
    .Sheets("Daten").Range("B9:B1500").Copy objWb.Sheets(strSheet).Range("B9")
    'Tabellenname anpassen
    .Sheets("Daten").Range("B1:B8").Copy objWb.Sheets(strSheet).Range("B1")
    'Tabellenname anpassen
End With

objWb.SaveAs strFile 'Datei speichern
'objWb.Close 'Datei schliessen

ErrExit:
GMS True

If Err.Number > 0 Then
    MsgBox Err.Number & vbLf & Err.Description, vbExclamation, "Fehler"
End If

Set objWb = Nothing
End Sub

Sub GMS(Optional ByVal Modus As Boolean = False)
Static lngCalc As Long

With Application
    .ScreenUpdating = Modus
    .EnableEvents = Modus
    .DisplayAlerts = Modus
    .EnableCancelKey = IIf(Modus, 1, 0)
    If Modus Then
        .Calculation = IIf(lngCalc <> 0, lngCalc, xlCalculationAutomatic)
    Else
        lngCalc = .Calculation
        .Calculation = xlCalculationManual
    End If
    .Cursor = IIf(Modus, -4143, 2)
    .CutCopyMode = False
End With

End Sub

Gruß Sepp

Beliebteste Forumthreads (12 Monate)

3 Beiträge zum Forumthread Beiträge zu diesem Forumthread

VBA Beispiele zu verwandten Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

3
Beiträge zum Forumthread

Beiträge zu diesem Forumthread