Microsoft Excel

Herbers Excel/VBA-Archiv

Informationen und Beispiele zum Thema MsgBox
BildScreenshot zu MsgBox MsgBox-Seite mit Beispielarbeitsmappe aufrufen

Erweiterung eines Codes

Betrifft: Erweiterung eines Codes von: Hartmut
Geschrieben am: 14.04.2015 11:06:58

Hallo zusammen,

in der untenstehenden Datei wird ein Vorlagen Sheet in einen Separaten Ordner abgelegt.
Dieses wird durch Eintrag einer fortlaufenden Nummer in Spalte F ausgelöst. Nach diesem Vorgang soll dieses Sheet automatisch zur weiteren Bearbeitung geöffnet werden.
Soweit funktioniert alles, nur das automatische öffnen noch nicht. Kann mir da jemand von euch helfen damit dieser letzte Schritt auch noch funktioniert.

Vielen Dank im voraus für eure Hilfe.

https://www.herber.de/bbs/user/97070.xlsm

  

Betrifft: AW: Erweiterung eines Codes von: Nepumuk
Geschrieben am: 14.04.2015 12:03:50

Hallo,

würde ich so machen:

Option Explicit

Private Declare PtrSafe Function MakeSureDirectoryPathExists Lib "imagehlp.dll" ( _
    ByVal DirPath As String) As Long
Private Declare PtrSafe Function CopyFileA Lib "kernel32.dll" ( _
    ByVal lpExistingFileName As String, _
    ByVal lpNewFileName As String, _
    ByVal bFailIfExists As Long) As Long

Private Sub Worksheet_Change(ByVal Target As Range)
    
    Const FOLDER_PATH As String = "G:\Eigene Dateien\" ' "C:\users\user\Documents\handover\"
    Const FILE_NAME As String = "Mappe1.xlsx" ' "Final_Handover_.xlsx"
    Const TP_COLUMN As Long = 6 ' **** Änderungen in Spalte F werden überwacht
    Const FIRST_ROW As Long = 2 ' **** Änderungen ab Zeile 2 werden überwacht
    Const FOLDER_COLUMN As Long = 4 'Spalte mit Ordnernamen hier D
    
    On Error GoTo Fehler
    
    Dim lngLastNumber As Long, lngReturn As Long
    Dim strFolder As String
    
    If Not Intersect(Target, Columns(TP_COLUMN)) Is Nothing And Target.Row >= FIRST_ROW Then
        If Not IsEmpty(Target.Offset(-1, 0).Value) Then
            'Letzte Ordner
            lngLastNumber = IIf(Target.Row = FIRST_ROW, 0, _
                Right$(Cells(Target.Row - 1, FOLDER_COLUMN).Value, 3))
            'Neuer Ordner
            strFolder = "TP_Handover_" & Format(lngLastNumber + 1, "000")
            'Neuen Ordner eintragen
            Application.EnableEvents = False
            Cells(Target.Row, FOLDER_COLUMN).Value = strFolder
            Application.EnableEvents = True
            strFolder = strFolder & "\"
            'Prüfen ob neuer Ordner schon existiert
            If Dir(FOLDER_PATH & strFolder, vbDirectory) = vbNullString Then
                ' Verzeichnis wird angelegt
                lngReturn = MakeSureDirectoryPathExists(FOLDER_PATH & strFolder)
                If lngReturn = 0 Then
                    Err.Raise Number:=vbObjectError + 1, Description:="Fehler beim Erstellen des Ordners"
                Else
                    'Dateicopy
                    lngReturn = CopyFileA(FOLDER_PATH & FILE_NAME, FOLDER_PATH & strFolder & FILE_NAME, 1)
                    If lngReturn = 0 Then
                        Err.Raise Number:=vbObjectError + 2, Description:="Fehler beim Kopieren der Datei"
                    Else
                        MsgBox "Ordner angelegt" & vbLf & vbLf & "und Dateien kopiert", vbInformation, "Information"
                        'Mappe öffnen
                        Workbooks.Open Filename:=FOLDER_PATH & strFolder & FILE_NAME
                    End If
                End If
            Else
                Err.Raise Number:=vbObjectError + 3, Description:="Ordner existiert bereits"
            End If
        Else
            Err.Raise Number:=vbObjectError + 4, Description:="Leerzeile vorher darf nicht sein"
        End If
    End If
    Exit Sub
    Fehler:
    If Err.Number <> 0 Then MsgBox "Fehler: " & Err.Number & vbLf & Err.Description, vbCritical, "Fehlermeldung"
    Application.EnableEvents = True
End Sub

Gruß
Nepumuk


  

Betrifft: AW: Erweiterung eines Codes von: Nepumuk
Geschrieben am: 14.04.2015 12:07:15

Da sind noch meine Daten drin, also so:

Option Explicit

Private Declare PtrSafe Function MakeSureDirectoryPathExists Lib "imagehlp.dll" ( _
    ByVal DirPath As String) As Long
Private Declare PtrSafe Function CopyFileA Lib "kernel32.dll" ( _
    ByVal lpExistingFileName As String, _
    ByVal lpNewFileName As String, _
    ByVal bFailIfExists As Long) As Long

Private Sub Worksheet_Change(ByVal Target As Range)
    
    Const FOLDER_PATH As String = "C:\users\user\Documents\handover\"
    Const FILE_NAME As String = "Final_Handover_.xlsx"
    Const TP_COLUMN As Long = 6 ' **** Änderungen in Spalte F werden überwacht
    Const FIRST_ROW As Long = 2 ' **** Änderungen ab Zeile 2 werden überwacht
    Const FOLDER_COLUMN As Long = 4 'Spalte mit Ordnernamen hier D
    
    On Error GoTo Fehler
    
    Dim lngLastNumber As Long, lngReturn As Long
    Dim strFolder As String
    
    If Not Intersect(Target, Columns(TP_COLUMN)) Is Nothing And Target.Row >= FIRST_ROW Then
        If Not IsEmpty(Target.Offset(-1, 0).Value) Then
            'Letzte Ordner
            lngLastNumber = IIf(Target.Row = FIRST_ROW, 0, _
                Right$(Cells(Target.Row - 1, FOLDER_COLUMN).Value, 3))
            'Neuer Ordner
            strFolder = "TP_Handover_" & Format(lngLastNumber + 1, "000")
            'Neuen Ordner eintragen
            Application.EnableEvents = False
            Cells(Target.Row, FOLDER_COLUMN).Value = strFolder
            Application.EnableEvents = True
            strFolder = strFolder & "\"
            'Prüfen ob neuer Ordner schon existiert
            If Dir(FOLDER_PATH & strFolder, vbDirectory) = vbNullString Then
                ' Verzeichnis wird angelegt
                lngReturn = MakeSureDirectoryPathExists(FOLDER_PATH & strFolder)
                If lngReturn = 0 Then
                    Err.Raise Number:=vbObjectError + 1, Description:="Fehler beim Erstellen des Ordners"
                Else
                    'Dateicopy
                    lngReturn = CopyFileA(FOLDER_PATH & FILE_NAME, FOLDER_PATH & strFolder & FILE_NAME, 1)
                    If lngReturn = 0 Then
                        Err.Raise Number:=vbObjectError + 2, Description:="Fehler beim Kopieren der Datei"
                    Else
                        MsgBox "Ordner angelegt" & vbLf & vbLf & "und Dateien kopiert", vbInformation, "Information"
                        'Mappe öffnen
                        Workbooks.Open Filename:=FOLDER_PATH & strFolder & FILE_NAME
                    End If
                End If
            Else
                Err.Raise Number:=vbObjectError + 3, Description:="Ordner existiert bereits"
            End If
        Else
            Err.Raise Number:=vbObjectError + 4, Description:="Leerzeile vorher darf nicht sein"
        End If
    End If
    Exit Sub
    Fehler:
    If Err.Number <> 0 Then MsgBox "Fehler: " & Err.Number & vbLf & Err.Description, vbCritical, "Fehlermeldung"
    Application.EnableEvents = True
End Sub

Gruß
Nepumuk


  

Betrifft: AW: Erweiterung eines Codes von: Hartmut
Geschrieben am: 14.04.2015 12:33:43

Hi Nepomuk,

danke auch für deine HIlfe.
Ich habe es noch nicht ausprobiert, da der Weg von Rudi auf Anhieb funktioniert hat.
Sobald ich Zeit habe werde ich es nachholen.
Nochmals ein großes Danke auch für deine Unterstützung.
Gruß
Hartmut


  

Betrifft: AW: Erweiterung eines Codes von: Rudi Maintaire
Geschrieben am: 14.04.2015 12:05:20

Hallo,
nach dem Kopieren einfach
Workbooks.open Pfad & Ordner & Mfile1

Gruß
Rudi


  

Betrifft: AW: Erweiterung eines Codes von: Hartmut
Geschrieben am: 14.04.2015 12:31:38

Hallo Rudi,
das klappt schonmal perfekt.
Danke dafür.
Könntest du mir noch in dieser HInsicht helfen das das Kopierte Sheet dann auch die letzte Nummer von der Tabelle bekommt.
Das wäre klasse.
Danke schon jetzt.
Gruß
Hartmut


  

Betrifft: AW: Erweiterung eines Codes von: Rudi Maintaire
Geschrieben am: 14.04.2015 12:47:20

Hallo,
das das Kopierte Sheet dann auch die letzte Nummer von der Tabelle bekommt
was willst du mir damit sagen?

Gruß
Rudi


  

Betrifft: AW: Erweiterung eines Codes von: Hartmut
Geschrieben am: 14.04.2015 13:06:26

Hallo Rudi,

sorry, ich meinte damit, das wenn die Vorlage "Final Handover.xlsx" in den Ordner kopiert wird dieses sheet dann z.B. die Endung.."Final Handover_205.xslx" bekommt.
Also die gleiche Zahl wie ich in der Tabelle eingegeben habe z.B. 205, 206...usw.

Gruß
Hartmut


  

Betrifft: AW: Erweiterung eines Codes von: Rudi Maintaire
Geschrieben am: 14.04.2015 14:17:54

Hallo,

FS.copyfile Pfad & Mfile1, Pfad & Ordner & "\Final_Handover_" & Target & ".xlsx", True 
Gruß
Rudi


  

Betrifft: AW: Erweiterung eines Codes von: Hartmut
Geschrieben am: 15.04.2015 10:53:35

Hallo Rudi,

erst einmal Danke für deine Hilfe.
Soweit funktioniert es. Nur werden jetzt 2 Sheets in den Ordner gelegt eines mit und eines ohne die Nummer der Tabelle.
Kannst du mir da noch den entscheidenden Tip geben.
Gruß
Hartmut


  

Betrifft: AW: Erweiterung eines Codes von: Nepumuk
Geschrieben am: 16.04.2015 07:26:49

Hallo,

die Zeile von Rudi soll die Zeile von dir ersetzen.

Gruß
Nepumuk


  

Betrifft: AW: Erweiterung eines Codes von: Hartmut
Geschrieben am: 16.04.2015 12:15:00

Hallo Nepumuk, hallo Rudi,

das habe ich mir schon gedacht, ich habe die betreffende Zeile auch ersetzt, allerdings kommt dann eine Fehlermeldung das das Dokument nicht gefunden werden kann. Wenn ich dieses mit "ok" bestätige, dann kommt eine weitere Fehlermeldung mit dem Fehler 1004. Es kann nicht auf dieses Sheet zugegriffen werden, weil das Dokument nicht vorhanden, Dokument wird verwendet, oder Arbeitsmappe in dem gespeichert werden soll ist Identisch mit dem Namen eines anderen Dokument welches schreibgeschützt ist.
Letztendlich wird das Sheet aber erstellt.
Vielleicht ist in dem gesamten Code noch eine Änderung vorzunehmen.
Gruß
Hartmut


  

Betrifft: AW: Erweiterung eines Codes von: Nepumuk
Geschrieben am: 16.04.2015 15:43:15

Hallo,

wie sieht denn die aktueller Code denn aus?

Gruß
Nepumuk


  

Betrifft: AW: Erweiterung eines Codes von: Hartmut
Geschrieben am: 16.04.2015 16:33:03

Hi Nepumuk,

habe den Fehler gefunden.
Ein Punkt war nicht an der richtigen Stelle. Das kommt davon wenn man zu Nah am Bildschirm sitzt.

:-)

Gruß und noch einmal Danke an euch
Hartmut