Werken met bestanden vanuit VBA

Status
Niet open voor verdere reacties.
K

Koezt

Gebruiker
Lid geworden
1 dec 2020
Berichten
7
Hallo,

Ik ben voor mijn werk bezig met een macro die een aantal bewerkingen doet op een Excelbestand. Deze repeterende handelingen worden tot nu toe handmatig uitgevoerd. Dit deel van de macro werkt inmiddels naar behoren. Om een aantal andere handelingen ook te vangen in deze macro wil ik het volgende doen.
In dezelfde folder waarin het Excelbestand staat waarop de macro draait, staat een mappenstructuur waarvan de eerste altijd Documents heet. Wat daar onder hangt verschilt bijna altijd, zowel in het aantal mappen, als het aantal niveaus. Ik zou graag deze mappenstructuur willen doorzoeken op bestanden met een drietal extensies (.pdf, .dxf en .stp). Het gaat hier vaak om honderden bestanden. Ik wil deze uit deze stuctuur verplaatsen naar een eigen map.

Nu:
Code: 
Folder
Werkmap met macro.xlsm
     Documenten
         Folder 1
             Folder 2
                   bestand.pdf
                   bestand.dxf
                   bestand.stp
Gewenst:
Code: 
Folder
Werkmap met macro.xlsm
    Map - PDF
        bestand.pdf
    Map - DXF
        bestand.dxf
    MAP - STP
        bestand.stp
Ik heb nu het volgende in mijn macro gezet:
Code: 
Set Fso = CreateObject("Scripting.FileSystemObject")
.
.
.
Set objFolder = Fso.GetFolder((FromPath) & "\Documents\")
.
.
.
For Each objSubFolder In objFolder.subfolders
    For Each FileInFolder In objSubFolder.Files
        If InStr(1, FileInFolder.Name, ".pdf") Then
            FileInFolder.Move (ActiveWorkbook.Path & "\" & Folderprefix & " - PDF" & "\")
        ElseIf InStr(1, FileInFolder.Name, ".dxf") Then
            FileInFolder.Move (ActiveWorkbook.Path & "\" & Folderprefix & " - DXF" & "\")
        ElseIf InStr(1, FileInFolder.Name, ".stp") Then
            FileInFolder.Move (ActiveWorkbook.Path & "\" & Folderprefix & " - STP" & "\")
        Else
            MsgBox "Geen bestanden gevonden"
        End If

    Next FileInFolder
Next objSubFolder

In principe doet dit wat ik wil. Helaas zoekt de macro maar een paar niveaus diep. Als ik handmatig alle .dxf, .pdf en .stp bestanden 2 niveaus diep heb staan. Werkt de macro. Staan de bestanden dieper in de structuur niet....

Dus als ik alles verplaats naar
Code: 
Documents
       MAP1
           bestanden
       Map2
            bestanden
       MAP3
             bestanden
Werkt het naar behoren.
Code: 
Documents
       MAP1
             MAPA
                  MAPA1
                        bestanden
       MAP2
             MAPB
                  MAPB2
                        bestanden
Werkt het niet...

Wie kan me hiermee helpen?
 
Laatst bewerkt:
En nu konkreet over da directory-struktuur:

C:\nivo\*.pdf ?
D:\nivo\documents\*.pdf ?
 
Pad ziet er als volgt uit

c:\workspace\Map(*1)\Documents\Map\MAP1\MAPA\MAPA1\bestanden

(*1) is niveau waar de Excel staat waaruit de macro gedraaid wordt.

Bestanden moeten naar nieuw aan te maken folder
c:\workspace\Map(*1)\MAP-PDF
c:\workspace\Map(*1)\MAP-DXF
c:\workspace\Map(*1)\MAP-STP

Na kopiëren zal ik de complete map Documents wissen.


Voor de volledigheid: Als de structuur er zo uitziet;
c:\workspace\Map(*1)\Documents\Map\bestanden

Werkt het...
 
Laatst bewerkt:
er wordt gekeken vanaf de subdirectory waar je excelfile staat.
Code: 
Sub Move_Allerlei_files()
   Dim MyPath, MyDir, MyFile, MijnFiles
   MyPath = LCase(ThisWorkbook.Path)             'path naar deze file (kleine letters)
   For Each ext In Array(".pdf", ".dxf", ".stp")   'je 3 extensies
      MijnFiles = Split(CreateObject("WScript.Shell").Exec("cmd /c dir " & MyPath & "\*" & ext & " /b /a-d /s ").StdOut.ReadAll, vbCrLf)   'alle die files in die subdirectorie en onderliggend
      For i = 0 To UBound(MijnFiles)             'resultaat 1 per 1 aflopen
         r = InStrRev(MijnFiles(i), "\")         'zoek laatste "\"
         If r > 0 Then
            MyDir = Left(MijnFiles(i), r - 1)
            MyFile = Mid(MijnFiles(i), r + 1)
            Select Case LCase(MyDir)             'vergelijken met kleine letters !!!
               Case MyPath, MyPath & "\blabla - pdf", MyPath & "\blabla - dxf", MyPath & "\blabla - stp"   'niet kijken in subdirectory waar excelfile staat + onderliggende subdirectories dpf, dxf en stp
               Case Else
                  MsgBox "op eigen risico, doe hier je move met files van type " & ext & vbLf & vbLf & MijnFiles(i) & vbLf & vbLf & "subdirectory : " & MyDir & vbLf & "filenaam : " & MyFile & vbLf & vbLf & i + 1 & "/" & UBound(MijnFiles)
            End Select
         End If
      Next
   Next
End Sub
Volgens mij gaat dit vrij snel, maar anders kan er ook op vrij analoge manier per subdirectory gemoved worden ipv. per individuele file, gewoon als info ter aanvulling.
Misschien iets linker ivm. foutafhandeling als een bepaalde filenaam al bestaat in de doeldirectory.
 
Laatst bewerkt:
Thanks. Dat ziet er heel bruikbaar uit. Krijg het echter nog niet aan de praat.

Kan het zijn dat er in de regel
MijnFiles = Split(CreateObject("WScript.Shell").Exec("cmd /c dir " & MyPath & "\*" & ext & " /b /a-d /s ").StdOut.ReadAll, vbCrLf)

Een punt mist?
MijnFiles = Split(CreateObject("WScript.Shell").Exec("cmd /c dir " & MyPath & "\*." & ext & " /b /a-d /s ").StdOut.ReadAll, vbCrLf)
 
hangt er van af of er in deze regel vooraan een punt staat of niet
Code: 
 For Each ext In Array("[COLOR="#FF0000"].[/COLOR]pdf", "[COLOR="#FF0000"].[/COLOR]dxf", "[COLOR="#FF0000"].[/COLOR]stp")   'je 3 extensies
Wat staat er daar bij jou ? en waar loop je vast ?
 
Laatst bewerkt:
Code: 
Dim fso As Object, objFolder As Object

Rootmap = ActiveWorkbook.Path & "\"
Set objFolder = fso.GetFolder((Rootmap) & "Documents")
.
.
.

For Each ext In Array(".pdf", ".dxf", ".stp")   'je 3 extensies
      MijnFiles = Split(CreateObject("WScript.Shell").Exec("cmd /c dir " & objFolder & "\*" & ext & " /b /a-d /s ").StdOut.ReadAll, vbCrLf)   'alle die files in die subdirectorie en onderliggend

      For I = 0 To UBound(MijnFiles)             'resultaat 1 per 1 aflopen
         r = InStrRev(MijnFiles(I), "\")         'zoek laatste "\"
         If r > 0 Then
            MyDir = Left(MijnFiles(I), r - 1)
            MyFile = Mid(MijnFiles(I), r + 1)
            Select Case LCase(MyDir)             'vergelijken met kleine letters !!!
               Case LCase(ActiveWorkbook.Path), PDFPath, DXFPath, STPPath   'niet kijken in subdirectory waar excelfile staat + onderliggende subdirectories dpf, dxf en stp
               Case Else
                 ' MsgBox "op eigen risico, doe hier je move met files van type " & ext & vbLf & vbLf & MijnFiles(I) & vbLf & vbLf & "subdirectory : " & MyDir & vbLf & "filenaam : " & MyFile & vbLf & vbLf & I + 1 & "/" & UBound(MijnFiles)
            End Select
         End If
      Next
   Next

Even wat waarden uit mijn Immediate window

File Path: C:\Workspace\AH-4000-001 (2020-11-26)\
OBJFOLDER: C:\Workspace\AH-4000-001 (2020-11-26)\Documents
Hoofdsam: AH-4000-001
Folderprefix: AH-4000-001 (2020-11-26)
PDFPath: C:\Workspace\AH-4000-001 (2020-11-26)\AH-4000-001 (2020-11-26) - PDF
DXFPath: C:\Workspace\AH-4000-001 (2020-11-26)\AH-4000-001 (2020-11-26) - DXF
STPPath: C:\Workspace\AH-4000-001 (2020-11-26)\AH-4000-001 (2020-11-26) - STP
XmitPath: C:\Workspace\AH-4000-001 (2020-11-26)\AH-4000-001 (2020-11-26) - Transmittal

Ik zie in het Locals venster een + verschijnen voor Mijnfiles; inhoud is echter <No Variables>
Ik zie ext wisselen van .pdf naar .dxf naar .stp
Maar Mijnfiles blijft leeg.
Op deze manier doe ik toch een dir C:\Workspace\AH-4000-001 (2020-11-26)\Documents\*.pdf in alle subfolders? (En dan *.dxf en *.stp)
 
Laatst bewerkt:
die objfolder, die nekt je in die opdrachtregel, dat is een object geen string
probeer volgend, in de msgbox van die 1e regel zou je achter die dir een deftige start-subdirectory en dan nog *.pdf (zie knipsel hieronder)
Bij jou zou dat dus "C:\Workspace\AH-4000-001 (2020-11-26)\Documents\*.pdf" moeten worden.
Krijg je dat niet, dan zal de volgende regel nooit deftig werken.
Code: 
msgbox "cmd /c dir " & rootmap & "documents\*" & ext
MijnFiles = Split(CreateObject("WScript.Shell").Exec("cmd /c dir " & rootmap & "documents\*" & ext & " /b /a-d /s ").StdOut.ReadAll, vbCrLf)   'alle die files in die subdirectorie en onderliggend
 

Bijlagen

  • Schermafbeelding 2020-12-02 154323.png
    Schermafbeelding 2020-12-02 154323.png
    5,9 KB · Weergaven: 19
Laatst bewerkt:
Untitled.png
2020-12-02 16_54_07-Locals.png

Msgbox klopt volgens mij (2e doorloop van de loop)
Mijnfiles blijft leeg.

Als ik in de commandprompt de opdrachten intyp, krijg ik ook niets.
2020-12-02 17_02_46-Command Prompt.png
Maar als ik eerst met CD er heen blader; bingo...

2020-12-02 17_03_20-Command Prompt.png

Dan zou het dus kunnen zitten in de spatie in de bestandsnaam?
 
Laatst bewerkt:
****, ja nu je het zegt, die spaties, daar was iets mee !
SNB heeft me toen geholpen, maar hoe ?
Moet ik opzoeken...
 
Dat is het in ieder geval wel. Heb voor nu de mappenstructuur aangepast door alle spaties te verwijderen. Nu vindt de macro in ieder geval de juiste hoeveelheid files.
Nu de move nog. Deze is risicoloos. Dubbele bestandsnamen komen bij ons niet voor. Conflicten op dat vlak zullen er niet optreden.

Wat gebeurt er in deze regel?
& ext & vbLf & vbLf & MijnFiles(I) & vbLf & vbLf & "subdirectory : " & MyDir & vbLf & "filenaam : " & MyFile & vbLf & vbLf & I + 1 & "/" & UBound(MijnFiles)
 
niets, dat is het laatste stuk van een msgbox, die in mijn #4 er nog volledig stond en in jouw #7 al een remark was.
In dat stuk moest je move komen, een wilde gok, iets in de zin van
Code: 
sp = Split(rootmap, "\")                      'knip rootmap in stukjes op "\"
   MsgBox "mijn doelmap wordt : " & rootmap & sp(UBound(sp) - 1) & " - " & Mid(ext, 2)   'msgbox die straks weg mag, enkel ter controle van je doelmap, dus laatste knipsel herhalen en " - " en ext zonder punt
   mijnfiles(i).Move rootmap & sp(UBound(sp) - 1) & " - " & Mid(ext, 2)   'de uiteindelijke move (gokje van mij)
 
https://exceloffthegrid.com/vba-code-to-copy-move-delete-and-manage-files/
ik ben nog even aan het stoeien geweest, dus hier en daar een aanpassing die je misschien moet checken
volgens bovenstaande link is een move van een file ook een rename !
Code: 
   rootmap = ThisWorkbook.Path & "\"
   sp = Split(rootmap, "\")
   For Each ext In Array(".pdf", ".dxf", ".stp")   'je 3 extensies
      doelmap = rootmap & sp(UBound(sp) - 1) & " - " & Mid(ext, 2)
      mijnfiles = Split(CreateObject("WScript.Shell").Exec("cmd /c dir " & rootmap & "\*" & ext & " /b /a-d /s ").StdOut.ReadAll, vbCrLf)   'alle die files in die subdirectorie en onderliggend

      For i = 0 To UBound(mijnfiles)             'resultaat 1 per 1 aflopen
         r = InStrRev(mijnfiles(i), "\")         'zoek laatste "\"
         If r > 0 Then
            MyDir = Left(mijnfiles(i), r - 1)    'path naar je file
            myfile = Mid(mijnfiles(i), r + 1)    'filenaam
            Select Case LCase(MyDir)             'vergelijken met kleine letters !!!
               Case LCase(ActiveWorkbook.Path), LCase(doelmap)   'niet kijken in subdirectory waar excelfile staat + onderliggende subdirectories dpf, dxf en stp
               Case Else
                  Name mijnfiles(i) As doelmap & "\" & myfile   'rename ipv move
            End Select
         End If
      Next
   Next
 
Suggestie met jokertekens:

Code: 
Sub M_snb()
   With CreateObject("scripting.filesystemobject")
       .MoveFile "G:\OF\*.PDF", "G:\PDF\"
    End With
End Sub
 
Nog een tijdje mee bezig geweest. Helaas heb ik het niet op deze manier werkend gekregen. Ik heb nu een 3 subroutines die per bestand de kopieer acties uitvoeren.
Zou eleganter kunnen, maar dat gaat me boven de pet... Thanks voor de hulp!
 
Status
Niet open voor verdere reacties.
Steun Ons

Nieuwste berichten

Terug
Bovenaan Onderaan