asked on

Vbscript: transfer sub till end sub based on groups

Hello experts,
I have .txt file (sub-procedures) in which I reported the various sub procedures that I use in my personal macro.
I listed the various procedures names in .csv file (procedures-listing)
I need a script that:
-Create the various txt files reported in csv file column b group
-Transfer procedure sub till end sub text based on the group related
-Create a txt files with the following name “Unknown-group” and transfer sub till end sub for procedures which are not reported in csv file with a related group
-Dummy files attached.
If you have questions, please contact me.
Thank you very much for your help.
sub-procedures.txt
procedures-listing.csv

Bill Prew

I would expect you would want the following at the top of each of the new "group scripts" text files, yes?

Option Explicit

'***************************************************************************
'PROCEDURES
'***************************************************************************
'***************************************************************************
''///Variables to be used by any Procedure
Dim oWs As Worksheet, oWb As Workbook
Dim rCl As Range, rRng As Range, uRng As Range
Dim Col As Long, lRw As Long, i As Long
Dim Val As String, sFldr As String, sFil As String, sPath As String
Dim Ans As Integer
Dim FSO As Object
'***************************************************************************

Open in new window

»bp

Bill Prew

Why do the last two entries in the CSV file have parms with them, when none of the other entries do? Which will be the actual format of the real CSV file?

 WorkOnEachFolderAndFolder(SourceFolder As Object, DrillDown As Boolean, ByRef r As Long);;;;;
 getFolder(ByRef prntfld As Object);;;;;

Open in new window

»bp

Luis Diaz

ASKER

Hello Bill.
-I will manage variables in a global module. Transfer should be applied just for procedures.
-I forgot to report groups for last two procedures. If not group reported transfer to unknown-group as the procedures not reported in column a
-Txt file for each group. Contain: the various related procedures.
Let me know if you have more questions.

Fabrice Lambert

Dim oWs As Worksheet, oWb As Workbook
Dim rCl As Range, rRng As Range, uRng As Range
Dim Col As Long, lRw As Long, i As Long
Dim Val As String, sFldr As String, sFil As String, sPath As String
Dim Ans As Integer
Dim FSO As Object

Open in new window

Are these global variables ?
After looking at your code,you don't need any.
Plus, proliferation of global variables is usually a sign of bad design, you should review it.

Also, choose better variables names, your are nowhere near meaningfull.

Luis Diaz

ASKER

Noted. What is the best practice in that case? Declare variables for each sub procedures? What is the best practice for variable name, lower at the beginning and finish with upper?

Fabrice Lambert

Declare variables for each sub procedures

Nope, declare variables only when you need them (declaring unused variables is a waste).
I also suggest to declare them right before using them for the 1st time, to reduce their lifetime (there are no reasons to declare a variable at top of a function if you only need it at the end).

What is the best practice for variable name

A good variable name should describe its intented use immediatly, without any ambiguity.
"Dim catName As String" denote a cat name, while "Dim cN As String" denote … (I have no clue)

lower at the beginning and finish with upper?

Forget any pefix / postfix notation, it only make you code tough to read and provide nothing usefull.

Luis Diaz

ASKER

Noted.
Declare when needed? In VBA I noticed that you can bypass then so when is needed? Could you please provide example?
I suppose that they also intend to avoid hard code. Example rootFolder to declare a folder path instead of declaring the full path?
Also I supposed when you need to limit the data this applied for integers and flags?
I also take the opportunity to ask clarifications about dim and set. When you dim you should set or what is the guideline for this?
Variables declaration not at the top don't bring complexity for code maintenance?

Bill Prew

Okay, worked this up kind of quick, but it seems to do what you want. Look it over, adjust as needed and give it a test there.

Keep in mind it appends to the group files when iut writes to them (naturally), so if you need to test multiple times detlete the group files from prior run first...

' Define needed I/O constants
Const ForReading = 1
Const ForWriting = 2
Const ForAppending = 8
Const TriStateUseDefault = -2

' Input file names
Const cInFile = "sub-procedures.txt"
Const cGroupFile = "procedures-listing.csv"
Const cUnknownGroup = "Unknown-group"


' Create filesystm object
Set objFSO = CreateObject("Scripting.FileSystemObject")

' Resolve to absolute paths
strInFile = objFSO.GetAbsolutePathname(cInFile)
strGroupFile = objFSO.GetAbsolutePathname(cGroupFile)

' Make sure input and match files exist
If Not objFSO.FileExists(strInFile) Then
    Wscript.Echo "*ERROR* Input file does not exist. (" & strInFile & ")"
    Wscript.Quit
End If
 
If Not objFSO.FileExists(strGroupFile) Then
    Wscript.Echo "*ERROR* Group file does not exist. (" & strGroupFile & ")"
    Wscript.Quit
End If

' Create dictionary object to locate groups
Set dicGroup = CreateObject("Scripting.Dictionary")
dicGroup.CompareMode = vbTextCompare

' Load group file into dictionary
With objFSO.OpenTextFile(strGroupFile, ForReading, False, TriStateUseDefault)
    arrLine = Split(.ReadAll, VbCrLf)
    .Close

    ' Loop through all lines of the file, load into a dictionary
    For Each strLine In arrLine
        ' Skip blank lines
        If strLine <> "" Then
            ' Parse by semicolon
            arrField = Split(Trim(strLine), ";")
            ' Only add if first column is not empty / blank
            If arrField(0) <> "" Then
                ' Add sub name as key, sub group as value
                dicGroup.Add Trim(arrField(0)), Trim(arrField(1))
            End If
        End If
    Next 
End With


' Load input file into array
With objFSO.OpenTextFile(strInFile, ForReading, False, TriStateUseDefault)
    arrLine = Split(.ReadAll, VbCrLf)
    .Close
End With


' Init loop variables
strProcText = ""
strSubGroup = ""

' Process each line of input file
For Each strLine In arrLine

    ' Trim for inspection
    strTrim = Trim(strLine)

    ' Did we hit the end of a sub?
    If LCase(Left(strTrim, 7)) = "end sub" Then
        strProcText = strProcText & strLine & vbCrLf
        ' If we found the sub group (means we hit a SUB for this END SUB) add this sub text to the group file
        If strSubGroup <> "" Then
            With objFSO.OpenTextFile(strSubGroup & ".txt", ForAppending, True, TriStateUseDefault)
                .WriteLine strProcText
                .Close
                strProcText = ""
                strSubGroup = ""
            End With
        End If

    ' Did we hit the beginning of a sub
    ElseIf LCase(Left(strTrim, 4)) = "sub " Then
        strProcText = strProcText & strLine & vbCrLf
        ' Isolate SUB name and look for it in dictionary, get group name if found, else use UNKNOWN group
        strSubName = Split(Split(strTrim, " ")(1), "(")(0)
        If dicGroup.Exists(strSubName) Then
            strSubGroup = dicGroup.Item(strSubName)
        Else
            strSubGroup = cUnknownGroup
        End If

    ' Not a SUB or END SUB, add it to the accumulated text...
    Else
        strProcText = strProcText & strLine & vbCrLf
    End If

Next

Open in new window

»bp

Fabrice Lambert

I'm not sure about what you mean by "bypass", as for "when is needed", most of the time it is right before initializing them.
Sample code:

Dim login As String    '// declaration
login = "user"    '// initialization

Dim password As String
password = "mypassword"

Dim encryptedPassword As String    '// declaration
encryptedPassword = encrypt(login, user)    '// initialization performed by the returned value of a function

Open in new window

Also I supposed when you need to limit the data this applied for integers and flags?

Nope, this apply to everything.

I also take the opportunity to ask clarifications about dim and set.

You use the Dim statement to declare a variable, no mater what type it is.
The set statement is used to instanciate an object, as these require dynamic memory allocation (anything that isn't string, integer, double, long, boolean, date)

Variables declaration not at the top don't bring complexity for code maintenance?

why would it be ?
Is it tougher to check if a variable have been declared 20 (if not more) lines above or 1 line above ?

Luis Diaz

ASKER

Bill, Thank you very much for this proposal.
I was wondering if it is possible to generate txt file in a YYYYMMDDMM folder to avoid deleting files when I execute the script.
I also realized that every procedure has a comment comment part.

'***************************************************************************
'Purpose:
'EE question:
'Validation Date:
'Pending actions:
'***************************************************************************

Open in new window

How to transfer the comment for each procedure? Do you recommend to add it after the Sub string or is there a way to include automatically?
Thank you very much for your help.

Bill Prew

I added logic to included the header just before each SUB in the code I provided, are you not getting that in your tests. For example, processing the sample files you provided, here is the "folders.txt" that was created. Notice the comment blocks...

'***************************************************************************
'Purpose:
'EE question:
'Validation Date:
'Pending actions:
'***************************************************************************
Sub List_Folders()

    Dim xPath As String
    Dim xWs As Worksheet
    Dim j As Long, folder1 As Object

    On Error GoTo exit_proc
    With Application
        .ScreenUpdating = False
        With .FileDialog(msoFileDialogFolderPicker)
            .Title = "Choose the folder"
            .Show
        End With
        On Error Resume Next
        xPath = .FileDialog(msoFileDialogFolderPicker).SelectedItems(1) & Application.PathSeparator
        .Workbooks.Add
        Set xWs = .ActiveSheet
        xWs.Cells(1, 1).Value = xPath
        xWs.Cells(2, 1).Resize(1, 5).Value = Array("Path", "Dir", "Name", "Date Created", "Date Last Modified")
        Set FSO = CreateObject("Scripting.FileSystemObject")
        Set folder1 = FSO.GetFolder(xPath)
        getSubFolder folder1
        xWs.Cells(2, 1).Resize(1, 5).Interior.Color = 65535
        xWs.Cells(2, 1).Resize(1, 5).EntireColumn.AutoFit
exit_proc:
        .ScreenUpdating = True
    End With
End Sub


'***************************************************************************
'Purpose: 'Purpose: This procedure intends to rename folder: Folder A rename full folder path: Example C:\Users\luis-\Documents\1.UF\9.Otros\Alimentation, vs new
'new folder column B C:\Users\luis-\Documents\1.UF\9.Otros\1.Alimentation
'Loop start as of row 2, To have root folder you can use the following formula =REPLACE(A2;FIND("^";SUBSTITUTE(A2;application.pathseparator;"^";LEN(A2)-LEN(SUBSTITUTE(A2;application.pathseparator;""))))+1;255;"")
'EE question:
'Validation Date:
'Pending actions: MsgBox to explain which are the requirements
'***************************************************************************
Sub Rename_Folders()

    Dim strOldDirName As String, strNewDirName As String
    Set oWs = ActiveSheet
    lRw = oWs.Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
    For i = 2 To lRw
        strOldDirName = oWs.Cells(i, "A").Value
        If Dir(strOldDirName, vbDirectory) = "" Then
            MsgBox "Folder '" & strOldDirName & "' in row " & i & " cannot be renamed as it doesn’t exist"
        Else
            strNewDirName = oWs.Cells(i, "B").Value
            On Error GoTo ErrorRename
            Name strOldDirName As strNewDirName
            On Error GoTo 0
        End If
    Next i

    Exit Sub

ErrorRename:
    MsgBox "Folder in row " & i & " cannot be renamed"
    Err.Clear
    Resume Next
End Sub



'***************************************************************************
'Purpose: Create specific folder and open it
'EE question: 29130499
'Validation Date:
'Pending actions: Link to ui
'***************************************************************************
Sub Create_Date_Stamp_Folder()
''/// allow user to open Directory
'This assumes that the root folder is listed in A1 of the Active Sheet
'If this is not the case, declare a Sheet Variable and set it accordingly and then qualify the range with the Sheet Refernce
'    If Range("A1").Value = "" Then
'        MsgBox "You haven't input the Report Folder in the cell A1.", vbExclamation
'        Exit Sub
'    End If
'sFolder = Range("A1").Value

''/// T think it would be better to allow the user to select the folder
    With Application.FileDialog(msoFileDialogFolderPicker)
        .Show
        If .SelectedItems.Count > 0 Then
            sFldr = .SelectedItems.Item(1)
        End If
    End With
    If Len(sFldr) = 0 Then
        MsgBox "No Folder selected", vbCritical
        Exit Sub
    End If
    '    sFolder = Range("A1").Value
    '    'Checking if the Root Folder doesn't exist.
    '    If Len(Dir(sFolder, vbDirectory)) = 0 Then
    '        MsgBox "The Report Folder doesn't exists.", vbExclamation, "Action Cancelled!"
    '        Exit Sub
    '    End If
    If Right(sFldr, 1) <> Application.PathSeparator Then sFldr = sFldr & Application.PathSeparator
    'Creating New Folder with DateTimeStamp inside the Root Folder
    sFldr = sFldr & Format(Now, "YYYYMMDD_HHMMSS")
    MkDir sFldr
    MsgBox "Report Folder " & sFldr & " has been created successfully.", vbInformation, "Report Folder Created!"
    Shell "C:\WINDOWS\explorer.exe """ & sFldr & "", vbNormalFocus
End Sub


'***************************************************************************
'Purpose: Remove specific folders reported in column A
'Reference site: https://exceloffthegrid.com/vba-code-to-copy-move-delete-and-manage-files/
'EE question: 29140370
'Validation Date:
'On Error GoTo Error_Routine:
'--------
'Exit Sub
'Error_Routine:
'    MsgBox "Unable to proceed, please check the consistency of data reported  (ie: file name with extension) or if file to rename is opened."
'***************************************************************************

Sub Remove_Folders()
    Set oWs = ActiveSheet
    Set FSO = CreateObject("Scripting.FileSystemObject")
    lRw = oWs.Range("A" & oWs.Rows.Count).End(xlUp).Row

    Ans = MsgBox("Before running this procedure, please check that" & _
                 vbNewLine & "Folders (full path) to remove are reported in column A (initial range A2)" & _
                 vbNewLine & "If so, please click on Yes else click on No.", vbQuestion + vbYesNo, "Confirm Please!")
    If Ans = vbNo Then Exit Sub

    For i = 2 To lRw
        sPath = oWs.Range("A" & i).Value

        'Check if folder exist
        If Not FSO.FolderExists(sPath) Then
            MsgBox "Folder: " & sPath & " doesn't exist, operation has been aborted", vbInformation
            Exit Sub
        End If

        'Delete folder
        FSO.DeleteFolder sPath

        MsgBox ("Folder " & sPath & " has been removed")
    Next i

End Sub

Open in new window

»bp

Bill Prew

Here's a change to add the date/time stamped folder for the output files.

' Define needed I/O constants
Const ForReading = 1
Const ForWriting = 2
Const ForAppending = 8
Const TriStateUseDefault = -2

' Input file names
Const cInFile = "B:\EE\EE29144099\sub-procedures.txt"
Const cGroupFile = "B:\EE\EE29144099\procedures-listing.csv"
Const cOutDir = "B:\EE\EE29144099"
Const cUnknownGroup = "Unknown-group"

' Create filesystm object
Set objFSO = CreateObject("Scripting.FileSystemObject")

' Resolve to absolute paths
strInFile = objFSO.GetAbsolutePathname(cInFile)
strGroupFile = objFSO.GetAbsolutePathname(cGroupFile)
strOutDir = cOutDir & "\" & Year(Now) & Right("0" & Month(Now), 2) & Right("0" & Day(Now), 2) & Right("0" & Hour(Now), 2) & Right("0" & Minute(Now), 2) & Right("0" & Second(Now), 2)

' Make sure input and match files exist
If Not objFSO.FileExists(strInFile) Then
    Wscript.Echo "*ERROR* Input file does not exist. (" & strInFile & ")"
    Wscript.Quit
End If
 
If Not objFSO.FileExists(strGroupFile) Then
    Wscript.Echo "*ERROR* Group file does not exist. (" & strGroupFile & ")"
    Wscript.Quit
End If

If Not objFSO.FolderExists(cOutDir) Then
    Wscript.Echo "*ERROR* Output folder does not exist. (" & cOutDir & ")"
    Wscript.Quit
End If

If Not objFSO.FolderExists(strOutDir) Then
    objFSO.CreateFolder(strOutDir)
End If

If Not objFSO.FolderExists(strOutDir) Then
    Wscript.Echo "*ERROR* Could not create output folder. (" & strOutDir & ")"
    Wscript.Quit
End If

' Create dictionary object to locate groups
Set dicGroup = CreateObject("Scripting.Dictionary")
dicGroup.CompareMode = vbTextCompare

' Load group file into dictionary
With objFSO.OpenTextFile(strGroupFile, ForReading, False, TriStateUseDefault)
    arrLine = Split(.ReadAll, VbCrLf)
    .Close

    ' Loop through all lines of the file, load into a dictionary
    For Each strLine In arrLine
        ' Skip blank lines
        If strLine <> "" Then
            ' Parse by semicolon
            arrField = Split(Trim(strLine), ";")
            ' Only add if first column is not empty / blank
            If arrField(0) <> "" Then
                ' Add sub name as key, sub group as value
                dicGroup.Add Trim(arrField(0)), Trim(arrField(1))
            End If
        End If
    Next 
End With


' Load input file into array
With objFSO.OpenTextFile(strInFile, ForReading, False, TriStateUseDefault)
    arrLine = Split(.ReadAll, VbCrLf)
    .Close
End With


' Init loop variables
strProcText = ""
strSubGroup = ""

' Process each line of input file
For Each strLine In arrLine

    ' Trim for inspection
    strTrim = Trim(strLine)

    ' Did we hit the end of a sub?
    If LCase(Left(strTrim, 7)) = "end sub" Then
        strProcText = strProcText & strLine & vbCrLf
        ' If we found the sub group (means we hit a SUB for this END SUB) add this sub text to the group file
        If strSubGroup <> "" Then
            With objFSO.OpenTextFile(strOutDir & "\" & strSubGroup & ".txt", ForAppending, True, TriStateUseDefault)
                .WriteLine strProcText
                .Close
                strProcText = ""
                strSubGroup = ""
            End With
        End If

    ' Did we hit the beginning of a sub
    ElseIf LCase(Left(strTrim, 4)) = "sub " Then
        strProcText = strProcText & strLine & vbCrLf
        ' Isolate SUB name and look for it in dictionary, get group name if found, else use UNKNOWN group
        strSubName = Split(Split(strTrim, " ")(1), "(")(0)
        If dicGroup.Exists(strSubName) Then
            strSubGroup = dicGroup.Item(strSubName)
        Else
            strSubGroup = cUnknownGroup
        End If

    ' Not a SUB or END SUB, add it to the accumulated text...
    Else
        strProcText = strProcText & strLine & vbCrLf
    End If

Next

Open in new window

»bp

Luis Diaz

ASKER

Thank you very much Bill, I will test it soon!

Luis Diaz

ASKER

Beautiful Bill!
It works. I think the folders shouldn't be defined with Const. possible to adjust so I select your proposal as solution?
I adjust as following:

' Define needed I/O constants
Const ForReading = 1
Const ForWriting = 2
Const ForAppending = 8
Const TriStateUseDefault = -2

' Input file names
strWorkingDir = Replace(WScript.ScriptFullName, WScript.ScriptName, "")
cInFile = strWorkingDir & "\sub-procedures.txt"
cGroupFile = strWorkingDir & "\procedures-listing.csv"
cOutDir = strWorkingDir
cUnknownGroup = "Unknown-group"

' Create filesystm object
Set objFSO = CreateObject("Scripting.FileSystemObject")

' Resolve to absolute paths
strInFile = objFSO.GetAbsolutePathname(cInFile)
strGroupFile = objFSO.GetAbsolutePathname(cGroupFile)
strOutDir = cOutDir & "\" & Year(Now) & Right("0" & Month(Now), 2) & Right("0" & Day(Now), 2) & Right("0" & Hour(Now), 2) & Right("0" & Minute(Now), 2) & Right("0" & Second(Now), 2)

' Make sure input and match files exist
If Not objFSO.FileExists(strInFile) Then
    Wscript.Echo "*ERROR* Input file does not exist. (" & strInFile & ")"
    Wscript.Quit
End If
 
If Not objFSO.FileExists(strGroupFile) Then
    Wscript.Echo "*ERROR* Group file does not exist. (" & strGroupFile & ")"
    Wscript.Quit
End If

If Not objFSO.FolderExists(cOutDir) Then
    Wscript.Echo "*ERROR* Output folder does not exist. (" & cOutDir & ")"
    Wscript.Quit
End If

If Not objFSO.FolderExists(strOutDir) Then
    objFSO.CreateFolder(strOutDir)
End If

If Not objFSO.FolderExists(strOutDir) Then
    Wscript.Echo "*ERROR* Could not create output folder. (" & strOutDir & ")"
    Wscript.Quit
End If

' Create dictionary object to locate groups
Set dicGroup = CreateObject("Scripting.Dictionary")
dicGroup.CompareMode = vbTextCompare

' Load group file into dictionary
With objFSO.OpenTextFile(strGroupFile, ForReading, False, TriStateUseDefault)
    arrLine = Split(.ReadAll, VbCrLf)
    .Close

    ' Loop through all lines of the file, load into a dictionary
    For Each strLine In arrLine
        ' Skip blank lines
        If strLine <> "" Then
            ' Parse by semicolon
            arrField = Split(Trim(strLine), ";")
            ' Only add if first column is not empty / blank
            If arrField(0) <> "" Then
                ' Add sub name as key, sub group as value
                dicGroup.Add Trim(arrField(0)), Trim(arrField(1))
            End If
        End If
    Next 
End With


' Load input file into array
With objFSO.OpenTextFile(strInFile, ForReading, False, TriStateUseDefault)
    arrLine = Split(.ReadAll, VbCrLf)
    .Close
End With


' Init loop variables
strProcText = ""
strSubGroup = ""

' Process each line of input file
For Each strLine In arrLine

    ' Trim for inspection
    strTrim = Trim(strLine)

    ' Did we hit the end of a sub?
    If LCase(Left(strTrim, 7)) = "end sub" Then
        strProcText = strProcText & strLine & vbCrLf
        ' If we found the sub group (means we hit a SUB for this END SUB) add this sub text to the group file
        If strSubGroup <> "" Then
            With objFSO.OpenTextFile(strOutDir & "\" & strSubGroup & ".txt", ForAppending, True, TriStateUseDefault)
                .WriteLine strProcText
                .Close
                strProcText = ""
                strSubGroup = ""
            End With
        End If

    ' Did we hit the beginning of a sub
    ElseIf LCase(Left(strTrim, 4)) = "sub " Then
        strProcText = strProcText & strLine & vbCrLf
        ' Isolate SUB name and look for it in dictionary, get group name if found, else use UNKNOWN group
        strSubName = Split(Split(strTrim, " ")(1), "(")(0)
        If dicGroup.Exists(strSubName) Then
            strSubGroup = dicGroup.Item(strSubName)
        Else
            strSubGroup = cUnknownGroup
        End If

    ' Not a SUB or END SUB, add it to the accumulated text...
    Else
        strProcText = strProcText & strLine & vbCrLf
    End If

Next

Open in new window

ASKER CERTIFIED SOLUTION

Bill Prew

membership

This solution is only available to members.

To access this solution, you must be a member of Experts Exchange.

Start Free Trial

Luis Diaz

ASKER

Thank you Bill!