Live-Forum - Die aktuellen Beiträge
Datum
Titel
28.03.2024 21:12:36
28.03.2024 18:31:49
Anzeige
Archiv - Navigation
1420to1424
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

Erweiterung eines Codes

Erweiterung eines Codes
14.04.2015 11:06:58
Hartmut
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

13
Beiträge zum Forumthread
Beiträge zu diesem Forumthread

Betreff
Datum
Anwender
Anzeige
AW: Erweiterung eines Codes
14.04.2015 12:03:50
Nepumuk
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

Anzeige
AW: Erweiterung eines Codes
14.04.2015 12:07:15
Nepumuk
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

Anzeige
AW: Erweiterung eines Codes
14.04.2015 12:33:43
Hartmut
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

AW: Erweiterung eines Codes
14.04.2015 12:05:20
Rudi
Hallo,
nach dem Kopieren einfach
Workbooks.open Pfad & Ordner & Mfile1
Gruß
Rudi

AW: Erweiterung eines Codes
14.04.2015 12:31:38
Hartmut
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

Anzeige
AW: Erweiterung eines Codes
14.04.2015 12:47:20
Rudi
Hallo,
das das Kopierte Sheet dann auch die letzte Nummer von der Tabelle bekommt
was willst du mir damit sagen?
Gruß
Rudi

AW: Erweiterung eines Codes
14.04.2015 13:06:26
Hartmut
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

AW: Erweiterung eines Codes
14.04.2015 14:17:54
Rudi
Hallo,
FS.copyfile Pfad & Mfile1, Pfad & Ordner & "\Final_Handover_" & Target & ".xlsx", True 
Gruß
Rudi

Anzeige
AW: Erweiterung eines Codes
15.04.2015 10:53:35
Hartmut
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

AW: Erweiterung eines Codes
16.04.2015 07:26:49
Nepumuk
Hallo,
die Zeile von Rudi soll die Zeile von dir ersetzen.
Gruß
Nepumuk

AW: Erweiterung eines Codes
16.04.2015 12:15:00
Hartmut
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

Anzeige
AW: Erweiterung eines Codes
16.04.2015 15:43:15
Nepumuk
Hallo,
wie sieht denn die aktueller Code denn aus?
Gruß
Nepumuk

AW: Erweiterung eines Codes
16.04.2015 16:33:03
Hartmut
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

Beliebteste Forumthreads (12 Monate)

Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige
Anzeige
Anzeige