PDA

View Full Version : [SOLVED] Using an array to transfer file names into workbook with multiple sheets



mongoose
07-07-2019, 04:13 PM
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.


PublicSub GetSOPFiles()
' 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.

Paul_Hossler
07-07-2019, 04:57 PM
Not tested, but maybe something like the BOLD?



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

mongoose
07-07-2019, 05:08 PM
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?

mongoose
07-08-2019, 05:28 AM
At the moment, it's just populating all of the cells in the defined range with one file name over and over again.


' 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

mongoose
07-08-2019, 05:44 AM
YES!..I got it working...somewhat..


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


I need that to be something like this...

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

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

Paul_Hossler
07-08-2019, 06:33 AM
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



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


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



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



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

mongoose
07-08-2019, 08:08 AM
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?

Paul_Hossler
07-09-2019, 10:53 AM
yes

#3 in my signature

mongoose
07-09-2019, 11:03 AM
Awesome. I see it, I'll mark it as solved now. Thank you again.