Microsoft Excel

Herbers Excel/VBA-Archiv

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

Dateien im Ordner öffenen; Ändern und speichern

Betrifft: Dateien im Ordner öffenen; Ändern und speichern von: Mike
Geschrieben am: 31.07.2014 09:37:35

Hallo Zusammen,

ich möchte mit Hilfe eines Makros alle Dateien in einem Ordner nacheinander öffnen. Dabei soll das Makro jede Datei aufmachen, die Werte in einer Spalte ändern und die Änderung speichern. Soviel hab ich schon mal rausgefunden:

Range("B2").Select
ActiveCell.FormulaR1C1 = "25"
Selection.AutoFill Destination:=Range("B2:B601")
Range("B2:B601").Select
ActiveWorkbook.Save
ActiveWindow.Close

jedoch habe ich so wenig VBA-Erfahrung, das ich auf eure Hilfe angewiesen bin. Weiß nicht, wie ich den Rest umsetzen kann. Hoffe mir kann einer helfen.

  

Betrifft: Dateien im Ordner öffenen; Ändern und speichern von: Hajo_Zi
Geschrieben am: 31.07.2014 10:02:12

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  _
& "  <<--"
'        Call importieren_und_verschieben(.FoundFiles(i))
'    Next i
'End With
'
Sub Start()
    SearchInFolder ThisWorkbook.Path
End Sub

Private Sub SearchInFolder(ByVal Folderspec As String)  ' auslesen aufrufen mit Ordnername
    Dim StTyp As String                                 ' Dateityp
    Dim FSO As New FileSystemObject
    Dim SearchFolder As Folder
    Dim FD As Folder, FI As File
    Dim EachFil As Files, EachFold As Folders
    Dim LoI As Long                                     ' Laufvariable zum schreiben der Ordner
    StTyp = "xl*"
    Set SearchFolder = FSO.GetFolder(Folderspec)
    Set EachFil = SearchFolder.Files            ' Dateien in der jeweiligen Root
    MsgBox EachFil.Count                        ' Anzahl Dateien
'   Dateien auslesen
    For Each FI In EachFil                      ' Schleife über alle Dateien
'       Dateityp feststellen
        If UCase(Right(FI.Name, Len(FI.Name) - InStrRev(FI.Name, "."))) = UCase(StTyp) Then
            Call importieren_und_verschieben(FI.Name)
        End If
    Next FI
    Set EachFil = Nothing
    Set EachFold = Nothing
    Set FSO = Nothing
End Sub

Sub importieren_und_verschieben(StDatei As String)
    MsgBox StDatei
End Sub
GrußformelHomepage


  

Betrifft: AW: Dateien im Ordner öffenen; Ändern und speichern von: Tino
Geschrieben am: 31.07.2014 10:22:21

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


  

Betrifft: AW: Dateien im Ordner öffenen; Ändern von: Mike
Geschrieben am: 31.07.2014 10:38:05

Vielen Dank erst mal Tino,

leider schmeißt der da noch irgendwie was durcheinander:

https://www.herber.de/bbs/user/91804.zip


  

Betrifft: AW: Dateien im Ordner öffenen; Ändern von: Mike
Geschrieben am: 31.07.2014 11:04:09

mir ist gerade noch was aufgefallen....und zwar hat die Tabelle immer den Namen der Datei....und wie gesagt schmeißt er da was durcheinander.....sorry aber wie ihr merkt hab ich keinen Plan


  

Betrifft: CSV Dateien von: Tino
Geschrieben am: 31.07.2014 12:50:56

Hallo,
hättest ja sagen können das sich um CSV Dateien handelt,
sind ja eigentlich Textdateien mit vorgegebenen Trennzeichen.

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
Gruß Tino


 

Beiträge aus den Excel-Beispielen zum Thema "Dateien im Ordner öffenen; Ändern und speichern"