Dateien im Ordner öffenen; Ändern und speichern

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Option Explicit ' Dieser Source stammt von http://www.activevb.de ' und kann frei verwendet werden. Für eventuelle Schäden ' wird nicht gehaftet. ' Der VB Code ist aus dem Beitrag _ http://www.activevb.de/tipps/vb6tipps/tipp0492.html ' Verweis: Microsoft Scripting Runtime ' Originalcode 'Dim i As Long 'With Application.FileSearch ' .NewSearch ' .LookIn = ActiveWorkbook.Path 'Suchverzeichnis ' .SearchSubFolders = False 'True wäre mit Unterverzeichnissen ' .Filename = "*.csv" 'Dateien die mit .csv änden ' .Execute 'suche ausführen ' For i = 1 To .FoundFiles.Count ' Application.StatusBar = "-->> Einlesen der Datei: " & i & " / " & .FoundFiles.Count _ & "

Hallo,
hier eine Variante zum testen!
Pfad wo die Dateien liegen und die Tabelle noch anpassen!

Sub Start()
Dim sDir$, sPath$, sFehler$
Dim arFiles()
Dim n&
'Pfad angeben *********************** 
sPath = "G:\Ordner\Neuer Ordner\"

If Right$(sPath, 1) <> "\" Then sPath = sPath & "\"

sDir = Dir$(sPath & "*.xls?", vbNormal)
Do While sDir <> ""
    Redim Preserve arFiles(n)
    arFiles(n) = sDir
    n = n + 1
    sDir = Dir$()
Loop

If n > 0 Then
    Events_ False
    On Error Resume Next
    For n = Lbound(arFiles) To Ubound(arFiles)
        With Workbooks.Open(sPath & arFiles(n))
            If Not .ReadOnly Then
                'Tabelle angeben ********************** 
                .Sheets("Tabelle1").Range("B2:B601").Value = 25
                If Err.Number = 0 Then
                    .Close True
                Else
                    sFehler = sFehler & arFiles(n) & " - Fehler: " & Err.Number & vbCr
                    .Close False
                    Err.Clear
                End If
            Else
                sFehler = sFehler & arFiles(n) & " - Schreibgeschützt" & vbCr
                .Close False
            End If
        End With
    Next n
    Events_ True
End If

If sFehler <> "" Then
    sFehler = Left$(sFehler, Len(sFehler) - 1)
    MsgBox "Datei mit Fehler!" & vbCr & vbCr & sFehler, vbExclamation
Else
    MsgBox "Fertig!", vbInformation
End If
End Sub

Sub Events_(booSchalter As Boolean)
With Application
    .ScreenUpdating = booSchalter
    .EnableEvents = booSchalter
    .DisplayAlerts = booSchalter
    .Calculation = IIf(booSchalter, xlCalculationAutomatic, xlCalculationManual)
End With
End Sub

Gruß Tino

Sub Start() Dim sDir$, sPath$, sInhalt$ Dim arFiles() Dim varInhalt, varTmp Dim n&, nn& Dim F% Const sDelimiter$ = ";" 'TRennzeichen sPath = "C:\Ordner\Ordner\" 'Pfad anpassen If Right$(sPath, 1) <> "\" Then sPath = sPath & "\" sDir = Dir$(sPath & "*.csv", vbNormal) Do While sDir <> "" Redim Preserve arFiles(n) arFiles(n) = sDir n = n + 1 sDir = Dir$() Loop If n > 0 Then For n = Lbound(arFiles) To Ubound(arFiles) F = FreeFile Open sPath & arFiles(n) For Binary As #F sInhalt = Space$(LOF(F)) Get #F, , sInhalt Close varInhalt = Split(sInhalt, vbCrLf) Kill sPath & arFiles(n) F = FreeFile Open sPath & arFiles(n) For Append As #F For nn = Lbound(varInhalt) To Ubound(varInhalt) If nn > 0 Then varTmp = Split(varInhalt(nn), sDelimiter) If Ubound(varTmp) > 0 Then varTmp(1) = 25 sInhalt = Join(varTmp, sDelimiter) Else sInhalt = varInhalt(nn) End If Print #F, sInhalt Next nn Close #F Next n End If MsgBox "Fertig!", vbInformation End Sub

Beliebteste Forumthreads (12 Monate)

Dateien im Ordner öffenen; Ändern und speichern

5
Beiträge zum Forumthread

Beiträge zu diesem Forumthread

75 Forumthreads zu ähnlichen Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

Dateien im Ordner öffenen; Ändern und speichern

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

75 Forumthreads zu ähnlichen Themen

VBA Beispiele zu verwandten Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

5
Beiträge zum Forumthread

Beiträge zu diesem Forumthread