Swap Dir with FSO in macro that loops through tm1 subsets

[Mathula Jr]

Hi guys below is a macro I created to mimmick the TM1 Print Report wizard to produce multiple reports from multiple subsets at once. The problem that I want to solve is that I am using the Dir function to loop through these subsets via a wildcard file search, this method means that I have to physically go to the data directory and cut only the subsets that I want to a new subset directory with a shorter path. If I don't do this and try to process the subsets in their original directory the use of the Dir function throws an error saying that the directory path is too long (bad directory)

I have since been told that the use of FSO in place of the Dir function can overcome this issue, but I am not really sure of how to utilize the FSO in the same way as I did the Dir function to do a wildcard file search in the subset directory in my macro. To be honest the FSO does not make much sense to me. Any help would be much appreciated guys.

Regards

Code: Select all

Sub Macro3()

    Dim NewName As String
    Dim ws As Worksheet
    Dim TM1Element As String
    Dim I As Integer
    Dim myDim As String
    Dim server As String
    Dim fullDim As String
    Dim folder As String
    Dim destination As String
    Dim Subset_Path As String
    Dim Subset As String
    Dim Subset_Less_Extension As String
    Dim currWb As Workbook
    Dim test As Worksheet
    Dim Name As String
    
    destination = "C:\Users\SK\Documents\TM1\V&P\"
    server = "gti_dev"
    myDim = "Cost Centre"
    fullDim = server & ":" & myDim
   
    Subset_Path = "C:\Users\SK\Documents\TM1\Subsets\" & "Shadow*.sub" 'Subset file directory
    Subset = Dir(Subset_Path, vbNormal) 'Variable storing Subset name with .Sub file extension
    
'Check if specified dimension exists
If Run("dimix", server & ":}Dimensions", myDim) = 0 Then
        MsgBox "The dimension does not exist on this server"
        Exit Sub
    End If
    
    Set currWb = ActiveWorkbook
    
    'Loop through all the Subsets in the Subset file directory
    While Subset <> ""
    
        Subset_Less_Extension = Left(Subset, Len(Subset) - 4)
        
        NewName = Right(Subset_Less_Extension, Len(Subset_Less_Extension) - 9)
        
        For I = 1 To Run("subsiz", fullDim, Subset_Less_Extension)
            TM1Element = Run("SUBNM", fullDim, Subset_Less_Extension, I, "")
            'MsgBox TM1Element
            currWb.Activate
            Range("$O$1").Value = "=SUBNM(""" & fullDim & """, "" & Subset_Less_Extension & "", """ & TM1Element & """, """")"
            Application.Run ("TM1RECALC")
'           Application.ScreenUpdating = False
            If I = 1 Then
                Sheets(1).Copy
                ActiveWorkbook.SaveAs Filename:=destination & NewName & ".xlsx", FileFormat:= _
                    xlOpenXMLWorkbook, CreateBackup:=False
                    
            Else
   Sheets("Budget").Copy After:=Workbooks(NewName & ".xlsx").Sheets(Workbooks(NewName & ".xlsx").Sheets.Count)
                                                
            End If
            
            
           'Sheets("template").Copy After:=Workbooks("NewBook").Sheets(Workbooks("NewBook").Sheets.Count)
            
             'If I = 1 Then
                'Sheets(1).Copy
                'ActiveWorkbook.SaveAs Filename:=destination & Subset_Less_Extension & ".xlsx", FileFormat:= _
                    'xlOpenXMLWorkbook, CreateBackup:=False
            'Else
                'Sheets(1).Copy After:=Workbooks(Subset_Less_Extension & ".xlsx").Sheets(1)
            'End If

            Cells.Copy
            Range("a1").Select
            Selection.PasteSpecial Paste:=xlValues
            Cells.Hyperlinks.Delete
            Application.CutCopyMode = False
            Cells(1, 1).Select
                     
            ActiveSheet.Name = Left(TM1Element, 31)
            Application.ScreenUpdating = True
        Next I
                   
        ActiveWorkbook.Save
        ActiveWorkbook.Saved = True
        ActiveWorkbook.Close savechanges:=False
                   
   'Retrieve the next Subset file in the directory
   Subset = Dir
  
  Wend
 Set currWb = Nothing

End Sub

[Wim Gielis]

Can you show us more information on why Dir() would not work? Screenshots for example?

Here's your original code but cleaned up - UNTESTED though:

Code: Select all

Sub Macro3()

    Dim NewName As String
    Dim TM1Element As String
    Dim I As Integer
    Dim fullDim As String
    Dim folder As String
    Dim Subset As String
    Dim Subset_Less_Extension As String
    Dim currWs As Worksheet
    
    Const destination As String = "C:\Users\SK\Documents\TM1\V&P\"
    Const server As String = "gti_dev"
    Const myDim As String = "Cost Centre"
    fullDim = server & ":" & myDim

    Const Subset_Path As String = "C:\Users\SK\Documents\TM1\Subsets\Shadow*.sub"    'Subset file directory
    Subset = Dir(Subset_Path)    'Variable storing Subset name with .Sub file extension

    'Check if specified dimension exists
    If Run("dimix", server & ":}Dimensions", myDim) = 0 Then
        MsgBox "The dimension does not exist on this server"
        Exit Sub
    End If

    Set currWs = ActiveSheet

    Application.ScreenUpdating = False
    
    'Loop through all the Subsets in the Subset file directory
    While Subset <> ""

        Subset_Less_Extension = Left(Subset, Len(Subset) - 4)
        NewName = Right(Subset_Less_Extension, Len(Subset_Less_Extension) - 9)

        For I = 1 To Run("subsiz", fullDim, Subset_Less_Extension)
            TM1Element = Run("SUBNM", fullDim, Subset_Less_Extension, I, "")
            
            Range("O1").Value = "=SUBNM(""" & fullDim & """, "" & Subset_Less_Extension & "", """ & TM1Element & """, """")"
            Application.Run "TM1RECALC"
            
            If I = 1 Then
                currWs.Copy
                Set wb = ActiveWorkbook
                wb.SaveAs Filename:=destination & NewName & ".xlsx", FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False
            Else
                Sheets("Budget").Copy After:=wb.Sheets(wb.Sheets.Count)
            End If

            With ActiveSheet.UsedRange
                .Value = .Value
                .Hyperlinks.Delete
                .Cells(1).Select
            End With

            ActiveSheet.Name = Left(TM1Element, 31)
        Next

        With wb
            .Save
            .Saved = True
            .Close 0
        End With

        'Retrieve the next Subset file in the directory
        Subset = Dir

    Wend

End Sub