Dateien bereitstellen und umwandeln

Hallo,
ich brauche mal wieder Hilfe. Ich habe zu diesem Zweck den Code mal hier eingefügt. Ich möchte alle Excel-Dateien eines variablen Ordners auslesen und in einer Exceldatei auflisten. Dann möchte ich von hieraus die Dateien öffnen/bearbeiten können. Wenn ich sie schließe soll der User wieder in der Ursprungsdatei sein. Er markiert dann eine Zelle, wenn Bearbeitung abgeschlossen ist. Dann möchte ich aus diese Datei, vorausgesetzt der Bearbeitungsstand steht auf abgeschlossen, ein Tabellenblatt auf einem anderen Laufwerk als csv-Datei bereitstellen. Nach erfolgreicher Bereitstellung soll in der Ursprungsdatei der Vermerk "Bereitstellúng erfolgreich" stehen. Soll eigentlich wie ein Formular aussehen.
Option Explicit
' Pfadangaben
Dim BasisPfad As String
Dim PfadDaten As String
Dim PfadMonat As String
Dim PfadMonatZahl As String
Dim PfadJahr As String
Dim GesamtPfad As String
Dim BasisPfadDB As String
Dim PfadDatenDB As String
Dim PfadMonatDB As String
Dim PfadMonatZahlDB As String
Dim PfadJahrDB As String
Dim GesamtPfadDB As String

Sub DatenKonvertierungStarten()
PfadSetzen
OrdnerAnlegen
DateienAuflistenDB
End Sub

Sub PfadSetzen()
With ThisWorkbook.Sheets("iWB")
BasisPfad = .Range("B4").Value
BasisPfadDB = "C:\Co"
PfadDaten = .Range("B5").Value
PfadDatenDB = "BD_"
PfadJahr = .Range("B6").Value
PfadMonat = Left(.Range("B7").Value, 3)
PfadMonatZahl = .Range("B8").Value
End With
GesamtPfad = BasisPfad + "\" + PfadDaten + "\" + PfadJahr + "\" + Format
(PfadMonatZahl, "00") + "_" + PfadMonat
GesamtPfadDB = BasisPfadDB + "\" + PfadDatenDB + PfadJahr + "\" + Format
(PfadMonatZahl, "00") + "_" + PfadMonat + "_" + PfadJahr + "\" + "Rechnungen"
End Sub

Sub OrdnerAnlegen()
'prüfen ob ein Ordner vorhanden ist und falls nicht fragen ob Ordner erstellt werden soll
Dim Ord As String
Dim Antwort As Integer
Ord = GesamtPfad
If Dir(Ord, vbDirectory)  "" Then
MsgBox "Der Ordner " + "'" + Format(PfadMonatZahl, "00") + "_" + PfadMonat
+ "'" + " ist schon vorhanden!"
Else
Antwort = MsgBox("Der Ordner " + "'" + Format(PfadMonatZahl, "00") + "_" +
PfadMonat + "'" + " ist nicht vorhanden." _
& vbNewLine _
& "soll der Ordner angelegt werden?!", vbYesNo)
If Antwort = vbYes Then
'Falls kein LW angegeben ist, erstellt die MkDir-Anweisung den neuen
Ordner auf dem aktuellen LW.
MkDir Ord
MsgBox "Ordner " + Format(PfadMonatZahl, "00") + "_" + PfadMonat + "
angelegt"
Else
MsgBox "Es wurden keine Änderungen vorgenommen"
Exit Sub
End If
End If
End Sub

Sub DateienAuflistenDB()
Dim fs As Object
Dim fVerz As Object
Dim fDatei As Object
Dim fdateien As Object
Dim strDat As String
Dim Zeile As Integer
Set fs = CreateObject("scripting.FileSystemObject")
Set fVerz = fs.getFolder(GesamtPfadDB)
Set fdateien = fVerz.Files
Range("A12:aa1000").Delete
Range("b12").Select
Zeile = 11
For Each fDatei In fdateien
If Right(fDatei, 3) = "xls" Or Right(fDatei, 4) = "xlsx" Or Right(fDatei, 4)
= "xlsm" Then
If InStr(fDatei, "") > 0 Then
Zeile = Zeile + 1
Cells(Zeile, 2) = fDatei.Name
End If
End If
Next fDatei
End Sub

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

'zusätzliches Makro in dem Modul mit den anderen Makros. Sub RechnungsDatei_oeffnen(strName As String) Application.Workbooks.Open Filename:=GesamtPfadDB & "\" & strName End Sub 'Code für Ereignismakro unter dem Tabellenblatt mit der Dateiliste Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean) If Target.Cells.Count = 1 Then If Target.Row >= 12 And Target.Column = 2 And Target.Value "" Then Cancel = True Target.Offset(0, 1).Select Call RechnungsDatei_oeffnen(strName:=Target.Text) End If End If End Sub

Sub DateienAuflistenDB() Dim fs As Object Dim fVerz As Object Dim fDatei As Object Dim fdateien As Object Dim strDat As String Dim Zeile As Integer Set fs = CreateObject("scripting.FileSystemObject") Set fVerz = fs.getFolder(GesamtPfadDB) Set fdateien = fVerz.Files Range("A12:aa1000").Delete Range("b12").Select Zeile = 11 For Each fDatei In fdateien If Right(fDatei, 3) = "xls" Or Right(fDatei, 4) = "xlsx" _ Or Right(fDatei, 4) = "xlsm" Then If InStr(fDatei, "") > 0 Then Zeile = Zeile + 1 Cells(Zeile, 2) = fDatei.Name ActiveSheet.Hyperlinks.Add anchor:=Cells(Zeile, 2), Address:=fDatei.Path End If End If Next fDatei End Sub

Hallo Tom,
ich hab die Wunschliste in fast vollständig umsetzen können.
https://www.herber.de/bbs/user/89667.xls

Der Bearbeitungsstand wird jetzt in einer Spalte mit Eintrag "O", "B" und "A" abgearbeitet
Es ist eine bedingte Formatierung eingerichtet und eine Datengültigkeitsprüfung mit DropDown-Auswahl.
Bei der Eingabe von Werten für den Bearbeitungsstand werden im Makro verschiedenste Prüfungen abgearbeitet.
So werden versehentliche Änderungen verhindert oder erst nach Bestätigung durchgeführt.
Wird der Stand " von "A" in einen anderen Stand zurückgesetz, dann wird eine bereits bereitgestellte csv-Datei ggf. wieder gelöscht. Der Name der csv-Datei wird dfür in einer weiteren Spalte eingetragen.

unnötige Spalten
Die vielen schmalen Spalten hab ich beseitigt. Es gibt zu jedem Spaltentitel nur noch eine Spalte mit entsprechender Breite. So ist die Tabelle übersichtliche, pflegeleichter und die unter VBA oft hinderlichen verbundenen Zellen werden vermieden.

unnöige Zeilen
Die Zeilen 13 und 14 hab ich gelöscht (sie sind unnötiger Balast) und Zeile 12 entsprechend formatiert, so dass Inhalte ggf. 2-zeilig angezeigt werden.

Name csv-Datei
Der Dateiname der CSV-Datei wird aus Spalte M im Blatt "Parameter" ausgelesen und zwar aus der letzten Zeile mit Daten

unerwünschte ";"
zur Beseitigung von unerwünschten ";" werden vor dem Speichern als CSV alle Spalten mit Daten rechts von Spalte M gelöscht.
Alle Zeilen unterhalb der letzten Zeile mit Werten &lt&gt "" werden gelöscht.
Falls die CSV-Datei jetzt immer noch unerwünschte ";" enthält, dann brauche ich mal eine Beispieldatei mit einem Parameter-Tabellenblatt und die dazugehörige CSV-Datei, wie sie nach dem Speichern aussehen soll.
Das Speichern als CSV müste dann komplett anders erfolgen oder ggf. die CSV nachbearbeitet werden.

Gruß
Franz

Beliebteste Forumthreads (12 Monate)

Dateien bereitstellen und umwandeln

17 Beiträge zum Forumthread Beiträge zu diesem Forumthread

VBA Beispiele zu verwandten Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

17
Beiträge zum Forumthread

Beiträge zu diesem Forumthread