Using an array to transfer file names into workbook with multiple sheets

What I am trying to do here is pull file names, sort them after parsing their file name (using SELECT to define the different values I am looking for), then transfer those filenames as an array over to each relevant sheet in the workbook.
I had a somewhat working function but it was really slow. After receiving some advice I decided to send the results to an array then use VBA to transfer values directly to worksheets; this is what I have so far.

Code:

---

PublicSub GetSOPFiles()


---

Code:

---

'  Set folder path
    Const FolderPath AsString="C:\Users\test\Desktop\SOP Audit Excel Prototype"

    Const FileExt AsString="docx"

    Dim Result AsVariant
    Dim i AsInteger
    Dim MyFile AsObject
    Dim MyFSO AsObject
    Dim MyFolder AsObject
    Dim MyFiles AsObject
    Dim dept AsVariant
    Dim deptCodes()AsVariant

    Set MyFSO = CreateObject("Scripting.FileSystemObject")
    Set MyFolder = MyFSO.GetFolder(FolderPath)
    Set MyFiles = MyFolder.Files

'  Research built-in Result function in VBA
    ReDim Result(1To MyFiles.Count)

    Dim vData AsVariant
    Dim sTemp AsVariant

'  Use a For loop to loop through the total number of sheets
    For i =1To12
'      Setup Select to determine dept values
        SelectCase i

            Case1
                deptCodes = Array("PNT","VLG","SAW")

            Case2
                deptCodes = Array("CRT","AST","SHP","SAW")

            Case3
                deptCodes = Array("CRT","STW","CHL","ALG","ALW","ALF","RTE","AFB","SAW")

            Case4
                deptCodes = Array("SCR","THR","WSH","GLW","PTR","SAW")

            Case5
                deptCodes = Array("PLB","SAW")

            Case6
                deptCodes = Array("DES")

            Case7
                deptCodes = Array("AMS")

            Case8
                deptCodes = Array("EST")

            Case9
                deptCodes = Array("PCT")

            Case10
                deptCodes = Array("PUR","INV")

            Case11
                deptCodes = Array("SAF")

            Case12
                deptCodes = Array("GEN")
        EndSelect

'      Loop through files in directory
        j =0
        ForEach MyFile In MyFiles
'          Limit files by file extension
            If InStr(1, MyFile.Name, FileExt)<>0Then
'              Explode file name into array and only pull files with defined dept codes
                Dim toSplitFileName AsVariant
                toSplitFileName = Split(MyFile.Name,"-")
                ForEach dept In deptCodes
                    If dept = toSplitFileName(3)Then
                        ReDimPreserve Result(0To j)
                        Result(j)= MyFile.Name
                        j = j +1
                    EndIf

'                  Send array to worksheet
                    Range("A1:A"& j).Value = Application.WorksheetFunction.Transpose(Result)
                Next dept
            EndIf
        Next MyFile
    Next
 EndSub

---

I'm trying to figure out how I could send the data to each sheet now. Say it loops through and finds all the files for SELECT Case 1, it sends all of those filenames to column A in Sheet 1. Same for Case 2, etc.
Thank you for your help everyone! After 3 book purchases and a lot of internet reading, I feel I'm starting to make some headway into VBA. Still have a lot to learn though.

Not tested, but maybe something like the BOLD?

Code:

---

'Send array to worksheet
Worksheets(I). Range("A1:A"& j).Value = Application.WorksheetFunction.Transpose(Result)

---

I thought of doing something like that before I posted but a couple of things came to mind....

1) I read in one of the books that I bought that you can only Preserve the uppermost element in a 1D array. Preserve doesn't work with a 2D array?
Say TestArray(x, y) with x being Sheet# and y being the filename but having to preserve the array values each time a match is found and a value has been added to array
2) I'm so unfamiliar with VBA that I can see the programming logic in my head, but then when I try to code it up I run into the simplest of issues which hold me back. Example code helps a lot at this noobie point in my VBA life.

What do you think, especially pertaining to point #1?

At the moment, it's just populating all of the cells in the defined range with one file name over and over again.

Code:

---

'      Loop through files in directory
        j =0
        ForEach MyFile In MyFiles
'          Limit files by file extension
            If InStr(1, MyFile.Name, FileExt)<>0Then
'              Explode file name into array and only pull files with defined dept codes
                Dim toSplitFileName AsVariant
                toSplitFileName = Split(MyFile.Name,"-")
                ForEach dept In deptCodes
                    If dept = toSplitFileName(3)Then
                        ReDimPreserve Result(0To j)
                        Result(j)= MyFile.Name
                        j = j +1
                    EndIf
                Next dept
            EndIf
        Next MyFile
'      Send array to worksheet       
        Range("A1:A20").Value = Application.WorksheetFunction.Transpose(Result)

---

Like so...

SOP-JV-016-DES-Test SOP Title-EN.docx

SOP-JV-016-DES-Test SOP Title-EN.docx

SOP-JV-016-DES-Test SOP Title-EN.docx

SOP-JV-016-DES-Test SOP Title-EN.docx

YES!..I got it working...somewhat..

Code:

---

'Send array to worksheet
Worksheets(i).Range("A1:A20").Value = Application.WorksheetFunction.Transpose(Result)

---

I need that to be something like this...

Code:

---

Worksheets(i).Range("A1:A" & j).Value = Application.WorksheetFunction.Transpose(Result)

---

But that is giving me an error. I assume is syntax...

Syntax-wise it looks ok, what was the error?


Result goes from 0 to j


Result(0 to 4) = AA, BB, CC, DD, EE in 0, 1, 2, 3, 4

Code:

---

Worksheets(i).Range("A1:A" & j).Value = Application.WorksheetFunction.Transpose(Result)

---

So I think you want something like this -- not tested

Code:

---

Worksheets(i).Range("A1").Resize(j+1,1).Value = Application.WorksheetFunction.Transpose(Result)

---

As an aside, I think the arrays over complicated it and really weren't needed for performance

Code:

---

Option Explicit


Public Sub GetSOPFiles()

'  Set folder path
    Const FolderPath As String = "C:\Users\test\Desktop\SOP Audit Excel Prototype"
    Const FileExt As String = "docx"

    Dim oFSO As Object
    Dim oFolder As Object
    Dim oFiles As Object
    Dim oFile As Object
    Set oFSO = CreateObject("Scripting.FileSystemObject")
    Set oFolder = oFSO.GetFolder(FolderPath)
    Set oFiles = oFolder.Files
    Dim v As Variant
    Dim iSheet As Long


    For Each oFile In oFiles
        If LCase(Right(oFile.Name, 4)) = FileExt Then
            v = Split(oFile.Name, "-")
       
            Select Case v(3)
                'Setup Select to determine dept values
                Case "PNT", "VLG", "SAW"
                    Call pvtPutOnSheet(oFile.Name, 1)
               
                Case "CRT", "AST", "SHP", "SAW"
                    Call pvtPutOnSheet(oFile.Name, 2)
   
                Case "CRT", "STW", "CHL", "ALG", "ALW", "ALF", "RTE", "AFB", "SAW"
                    Call pvtPutOnSheet(oFile.Name, 3)
   
                Case "SCR", "THR", "WSH", "GLW", "PTR", "SAW"
                    Call pvtPutOnSheet(oFile.Name, 4)
   
                Case "PLB", "SAW"
                    Call pvtPutOnSheet(oFile.Name, 5)
   
                Case "DES"
                    Call pvtPutOnSheet(oFile.Name, 6)
   
                Case "AMS"
                    Call pvtPutOnSheet(oFile.Name, 7)
   
                Case "EST"
                    Call pvtPutOnSheet(oFile.Name, 8)
   
                Case "PCT"
                    Call pvtPutOnSheet(oFile.Name, 9)
   
                Case "PUR", "INV"
                    Call pvtPutOnSheet(oFile.Name, 10)
   
                Case "SAF"
                    Call pvtPutOnSheet(oFile.Name, 11)
   
                Case "GEN"
                    Call pvtPutOnSheet(oFile.Name, 12)
            End Select
        End If
    Next oFile
 End Sub


Private Sub pvtPutOnSheet(s As String, i As Long)
    Dim r As Range
   
    With Worksheets(i)
        Set r = .Cells(.Rows.Count, 1).End(xlUp)
        If Len(r.Value) > 0 Then Set r = r.Offset(1, 0)
           
        r.Value = s
    End With
End Sub



---

Amazing. I was just on to my next question. I had everything working but when I started to try to run it against the files on the network it started to act up. The arrays must have really been slowing it down. Everything is working great; now I can move on to the next part of the file that I need to develop.

Is there a way to mark a response as the answer to my thread?

yes

#3 in my signature

Awesome. I see it, I'll mark it as solved now. Thank you again.