Bepalen welke 3-letter codes zich in de bestandsnamen bevinden

[robert123321]

Hallo,

ik ben al een tijdje aan het stoeien om het volgende voor elkaar te krijgen:

Ik gebruik een macro om in een folder te bepalen welke files zich daar bevinden. Deze files zijn altijd opgebouwd op de volgende manier: *_*_*_*_*.ab1 (vb. 12345_F_FGF_001_PT1.ab1)
Het eerste deel kan overigens in aantal karakters verschillen.
Wat ik graag wil is dat de macro bepaald voor elk bestand wat voor 3-letter code zich onder het 3e sterretje (*) bevind en vervolgens een map aanmaakt met als naam de 3-lettercode en dan het bestand naar deze map verplaatst.
Het verplaatsen gaat mij zelf wel lukken, maar ik krijg het niet voor elkaar om de macro de 3-lettercode eruit te laten filteren. Dit is mijn code tot nu toe:

Dim strFileArray()
Dim GenArray()
Dim lngLoop As Long

    
    With Application.FileSearch
        .NewSearch
        .LookIn = extraPath   [COLOR="SeaGreen"]'<======= de geselecteerde folder, wordt gegenereerd in een eerder deel van de macro[/COLOR]
        .SearchSubFolders = False
        .FileType = msoFileTypeAllFiles
        .Execute
        ReDim strFileArray(.FoundFiles.Count)
        For lngLoop = 1 To .FoundFiles.Count
            strFileArray(lngLoop) = .FoundFiles(lngLoop)
                    With strFileArray(lngLoop)
                        GenArray() = strFileArray     [COLOR="SeaGreen"]'<=======hier een loop die bepaald welke genen (3-lettercodes) zich in de map bevinden.[/COLOR]
                    End With
        Next lngLoop
    End With
    For x = 1 To UBound(strFileArray) [COLOR="SeaGreen"]'<==== Of hier evt de 3-letter codes bepalen, als dat handiger is. [/COLOR]
        oldname = strFileArray(x)
        Filename = oldname
    Next    'x

Mijn dank zal groot zijn.

Gr Robert

 

[japiepatat]

Ik heb nu geen tijd om het helemaal voor je uit te zoeken maar zou het lukken met een combinatie van een loop en een InStr functie? Waarbij je de positie bepaalt van de 3e underscore en vervolgens de 3 tekens daarna uitleest?


Groeten,

Johan van den Brink
Nimda
http://www.nimda.nl

 

[jofred]

Robert,

Wellicht dat dit je hier wat verder mee komt.

strNaam = Mid(strNaam, InStr(1, strNaam, "_") + 1)
strNaam = Mid(strNaam, InStr(1, strNaam, "_") + 1, 3)

strNaam is de bestandsnaam die je uitleest.

 

[robert123321]

Opgelost!

Robert,

Wellicht dat dit je hier wat verder mee komt.

strNaam = Mid(strNaam, InStr(1, strNaam, "_") + 1)
strNaam = Mid(strNaam, InStr(1, strNaam, "_") + 1, 3)

strNaam is de bestandsnaam die je uitleest.

Ik was er zelf al achter gekomen met inderdaad een soortgelijk code (zie blauwe code), maar ik ga die van jou ook even proberen. Bedankt!

    With Application.FileSearch
        .NewSearch
        .LookIn = extraPath   '<======= de geselecteerde folder
        .SearchSubFolders = False
        .FileType = msoFileTypeAllFiles
        .Execute
        ReDim strFileArray(.FoundFiles.Count)
        For lngLoop = 1 To .FoundFiles.Count
            strFileArray(lngLoop) = .FoundFiles(lngLoop)
                    With strFileArray(lngLoop)
                        GenArray() = strFileArray     '<=======Maakt een Array met de files
                    End With
        Next lngLoop
    End With
    For x = 1 To UBound(GenArray) '<==== Loop door de filenamen
        On Error Resume Next
        oldname = strFileArray(x)
        Filename = Mid(oldname, InStrRev(oldname, "\") + 1)
        If InStr(Filename, "_F_") > 0 Then                          '<==== Bepaald het gen in de forward file
            G[COLOR="RoyalBlue"]en = Mid(Filename, InStrRev(Filename, "_F_") + 3)
            Gen = Left(Gen, InStrRev(Gen, "_") - 1)
            Gen = Left(Gen, InStrRev(Gen, "_") - 1)[/COLOR]
            MkDir extraPath & "\" & Gen
            FSO.CopyFile Source:=oldname, Destination:=extraPath & "\" & Gen & "\"
            Kill oldname
        Else
            [COLOR="RoyalBlue"]Gen = Mid(Filename, InStrRev(Filename, "_R_") + 3)      '<==== Bepaald het gen in de reverse file
            Gen = Left(Gen, InStrRev(Gen, "_") - 1)
            Gen = Left(Gen, InStrRev(Gen, "_") - 1)[/COLOR]
            MkDir extraPath & "\" & Gen
            FSO.CopyFile Source:=oldname, Destination:=extraPath & "\" & Gen & "\"
            Kill oldname
       End If
                
    Next    'x