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

VBA erweitern

VBA erweitern
19.07.2016 10:39:36
Susi
Hallo zusammen,
ich wurde schon einmal geholfen und hoffe jetzt das mir jemand weiterhilft.
Ich habe folgenden Code:
Private Sub CommandButton2_Click()
Dim ablagepfad As String
Dim dateiname As String
Dim pfaderledigt As String
Dim zieldatei As Object
Dim quelle As Object
Dim letztezeile As Long
Dim zeilequelle
Application.ScreenUpdating = False
'die Zieldatei, da wo das Makro ausgeführt wird
Set zieldatei = ThisWorkbook.Sheets("Daten aus CsV")
'Zeile in die eingetragen wird
letztezeile = zieldatei.Cells(Rows.Count, 1).End(xlUp).Row + 1
'pfad für die Ausgangs CSV Dateien
ablagepfad = "I:\Vorlage2\Re_csv"
If Right(ablagepfad, 1)  "\" Then ablagepfad = ablagepfad & "\"
'pfad wohin abgelegt werden soll, also die erledigten
pfaderledigt = "I:\Vorlage2\Re_erl"
If Right(pfaderledigt, 1)  "\" Then pfaderledigt = pfaderledigt & "\"
'erste Datei suchen
dateiname = Dir(ablagepfad & "*.csv")
'wenn keine Datei gefunden, Meldung und Abbruch
If dateiname = "" Then
MsgBox "Keinen DATEN vorhanden.", , "Fehler bei Suche"
End
End If
'falls gefunden, alle durchgehen
Do Until dateiname = ""
'Dateien öffnen
Workbooks.Open ablagepfad & dateiname
Set quelle = ActiveWorkbook
'in Spaltenaufteilen
ActiveSheet.Columns(1).Select
Selection.TextToColumns Destination:=Range("A1"), DataType:=xlDelimited, _
TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=True, Tab:=True, _
Semicolon:=False, Comma:=False, Space:=True, Other:=True, OtherChar:= _
"""", FieldInfo:=Array(Array(1, 1), Array(2, 1), Array(3, 1), _
Array(4, 1), Array(5, 1), Array(6, 1), Array(7, 1), Array(8, 1), _
Array(9, 1)), TrailingMinusNumbers:=True
'Anzahl der einzutragendenzeilen ermitteln
zeilequelle = ActiveSheet.Cells(ActiveSheet.Rows.Count, 1).End(xlUp).Row
'Daten kopieren
quelle.Worksheets(1).Range(quelle.Worksheets(1).Cells(2, 1), _
quelle.Worksheets(1).Cells(zeilequelle, 9)).Copy zieldatei _
.Cells(letztezeile, 1)
'Datum und Zeit des Übertrages rein
zieldatei.Cells(letztezeile, 11) = Now
'Zeile für nächsten Eintrag neu setzen
letztezeile = letztezeile + zeilequelle - 1
'csv schließen
quelle.Close savechanges:=False
'CSV umbenennen und verschieben
Name ablagepfad & dateiname As pfaderledigt & Left(dateiname, Len(dateiname) - 4) _
& " " & Replace(Now, ":", ".") & ".csv"
'nächste CSV suchen
dateiname = Dir
Loop
'Formate noch anpassen, Spaltenbreite an Text anpassen + Format auf Zahl für Spalte B C
zieldatei.Columns("A:K").AutoFit
zieldatei.Columns("B:C").NumberFormat = "0"
With zieldatei.Columns("A:I").Borders
.Weight = xlThin
.LineStyle = xlContinuous
End With
Set zieldatei = Nothing
Set quelle = Nothing
Application.ScreenUpdating = True
End Sub
Frage1 : Bei Fertigung des Codes soll eine Meldung kommen:
"Alle Dateien wurden gezogen"
Frage 2:
Der Code bezieht sich auf I:\Vorlage2\Re_erl
Wenn ein Mitarbeiter den Ordner Vorlage2 ändert auf Vorlage2_Test
dann geht es nimmer. Kann man den Code so erstellen, das man den Ordner ändern kann ?
Aber es bleibt immer Vorlage2 danach ein _ dann kommt der neue Name.
Also Vorlage2_Test
Besten Dank , hoffe das ihr mir dabei Hilft
Danke
Leibe Grüße Susi

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

Betreff
Datum
Anwender
Anzeige
AW: VBA erweitern
19.07.2016 11:04:48
JoWE
Hallo Susi,
zu Frage 1, gib eine MessageBox aus: "Msgbox"Fertig!",vbokonly,"Erfolgsmeldung"
zu Frage 2:
Mach' eine Ordnervorauswahl zur Selektion des Vorlagenordners,
z.B. so:
Public Function VerzeichnisAuswaehlen()
Dim objFiledialog As FileDialog
Set objFiledialog = _
Application.FileDialog(msoFileDialogFolderPicker)
With objFiledialog
.AllowMultiSelect = False
If .Show = True Then
VerzeichnisAuswaehlen = .SelectedItems(1)
End If
End With
Set objFiledialog = Nothing
MsgBox VerzeichnisAuswaehlen
End Function
Gruß
Jochen
AW: VBA erweitern
19.07.2016 11:08:44
Susi
Hallo Jochen,
kannst du mir sagen wie und wo ich das einsetzte?
Susi
Anzeige
AW: Uwe war schneller..:-).
19.07.2016 11:21:51
JoWE
Gruß
Jochen
AW: VBA erweitern
19.07.2016 11:12:09
UweD
Hallo Susi
Versuch das mal.
Option Explicit 
 
Private Sub CommandButton2_Click() 
 
    Dim ablagepfad As String 
    Dim dateiname As String 
    Dim pfaderledigt As String 
    Dim zieldatei As Object 
    Dim quelle As Object 
    Dim letztezeile As Long 
    Dim zeilequelle 
    Dim DLG 
 
    Application.ScreenUpdating = False 
     
    'die Zieldatei, da wo das Makro ausgeführt wird 
    Set zieldatei = ThisWorkbook.Sheets("Daten aus CsV") 
     
    'Zeile in die eingetragen wird 
    letztezeile = zieldatei.Cells(Rows.Count, 1).End(xlUp).Row + 1 
     
    'pfad für die Ausgangs CSV Dateien 
     Set DLG = Application.FileDialog(msoFileDialogFolderPicker) 'Verzeichnis wählen 
     With DLG 
        .InitialFileName = "I:\Vorlage2\" 'Welches Verzeichnis soll voreingestellt sein 
        If .Show = True Then 
            ablagepfad = DLG.SelectedItems(1) & "\Re_csv\" 
        End If 
     
        'pfad wohin abgelegt werden soll, also die erledigten 
        pfaderledigt = .SelectedItems(1) & "\Re_erl\" 
    End With 
    'erste Datei suchen 
    dateiname = Dir(ablagepfad & "*.csv") 
    'wenn keine Datei gefunden, Meldung und Abbruch 
    If dateiname = "" Then 
        MsgBox "Keinen DATEN vorhanden.", , "Fehler bei Suche" 
        End 
    End If 
 
    'falls gefunden, alle durchgehen 
    Do Until dateiname = "" 
        'Dateien öffnen 
        Workbooks.Open ablagepfad & dateiname 
     
        Set quelle = ActiveWorkbook 
        'in Spaltenaufteilen 
        ActiveSheet.Columns(1).Select 
        Selection.TextToColumns Destination:=Range("A1"), DataType:=xlDelimited, _
            TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=True, Tab:=True, _
            Semicolon:=False, Comma:=False, Space:=True, Other:=True, OtherChar:= _
            """", FieldInfo:=Array(Array(1, 1), Array(2, 1), Array(3, 1), _
            Array(4, 1), Array(5, 1), Array(6, 1), Array(7, 1), Array(8, 1), _
            Array(9, 1)), TrailingMinusNumbers:=True 
        'Anzahl der einzutragendenzeilen ermitteln 
        zeilequelle = ActiveSheet.Cells(ActiveSheet.Rows.Count, 1).End(xlUp).Row 
        'Daten kopieren 
        quelle.Worksheets(1).Range(quelle.Worksheets(1).Cells(2, 1), _
        quelle.Worksheets(1).Cells(zeilequelle, 9)).Copy zieldatei _
        .Cells(letztezeile, 1) 
        'Datum und Zeit des Übertrages rein 
        zieldatei.Cells(letztezeile, 11) = Now 
        'Zeile für nächsten Eintrag neu setzen 
        letztezeile = letztezeile + zeilequelle - 1 
        'csv schließen 
        quelle.Close savechanges:=False 
        'CSV umbenennen und verschieben 
        Name ablagepfad & dateiname As pfaderledigt & Left(dateiname, Len(dateiname) - 4) _
        & " " & Replace(Now, ":", ".") & ".csv" 
        'nächste CSV suchen 
        dateiname = Dir 
    Loop 
    MsgBox "Alle Dateien wurden gezogen" 
    'Formate noch anpassen, Spaltenbreite an Text anpassen + Format auf Zahl für Spalte B C 
    zieldatei.Columns("A:K").AutoFit 
    zieldatei.Columns("B:C").NumberFormat = "0" 
     
    With zieldatei.Columns("A:I").Borders 
        .Weight = xlThin 
        .LineStyle = xlContinuous 
    End With 
     
    Set zieldatei = Nothing 
    Set quelle = Nothing 
    Application.ScreenUpdating = True 
End Sub 
 

VBA/HTML-CodeConverter, AddIn für Office 2002-2016 - in VBA geschrieben von Lukas Mosimann. Projektbetreuung:RMH Software & Media

Code erstellt und getestet in Office 15 - mit VBAHTML 12.6.0


Gruß UweD
Anzeige
Danke an alle :-)
19.07.2016 18:16:56
Susi
. Hat geklappt.
lg susi

Links zu Excel-Dialogen

Beliebteste Forumthreads (12 Monate)

Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige
Anzeige
Anzeige