Posts by ir121973

Public Sub ListFilesInFolder(SourceFolder As Scripting.folder, IncludeSubfolders As Boolean)




    Dim LastRow As Long




    On Error Resume Next
    For Each FileItem In SourceFolder.Files
        ' display file properties
        Cells(iRow, 3).Formula = iRow - 12
        Cells(iRow, 4).Formula = FileItem.Name
        Cells(iRow, 5).Select
        Selection.Hyperlinks.Add Anchor:=Selection, Address:= _
        FileItem.Path, TextToDisplay:="Click Here to Open"
        iRow = iRow + 1 ' next row number




        With ActiveSheet
        LastRow = .Cells(.Rows.Count, "C").End(xlUp).Row
        LastRow = Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
    End With




For Each Cell In Range("C13:E" & LastRow) ''change range accordingly
    If Cell.Row Mod 2 = 1 Then ''highlights row 2,4,6 etc|= 0 highlights 1,3,5
        Cell.Interior.Color = RGB(232, 232, 232) ''color to preference
    Else
        Cell.Interior.Color = RGB(141, 180, 226) 'color to preference or remove
    End If
Next Cell
    Next FileItem




    If IncludeSubfolders Then
        For Each SubFolder In SourceFolder.SubFolders
            ListFilesInFolder SubFolder, True
        Next SubFolder
    End If
    Set FileItem = Nothing
    Set SourceFolder = Nothing
    Set FSO = Nothing
End Sub

Sub btnFetchFiles()
    
    Dim file As String




    iRow = 7
    fPath = "\\c\s\CAF2\SA\Accessibility\Dragon - Application-Specific Script Conversion 2014\Converted Scripts\Done\"
    file = Dir(fPath & "*.dat")
    If file <> "" Then




        Set FSO = New Scripting.FileSystemObject
        If FSO.FolderExists(file) <> False Then
            Set SourceFolder = FSO.GetFolder(file)




                IsSubFolder = True




                Call ListFilesInFolder(SourceFolder, IsSubFolder)
                Call ResultSorting(xlAscending, "C7")
        Else
            MsgBox "Selected Path Does Not Exist !!" & vbNewLine & vbNewLine & "Select Correct One and Try Again !!", vbInformation, "File Manager - http://www.LearnExcelMacro.Com"
        End If
    End If
End Sub

'Define Constants to indicate use of OVERHEADS or PROJECTS
    Const nUseAllDIR As Integer = 1
    Const nUseAllEH As Integer = 2
    Const nUseAllIND As Integer = 3
    Const nUseAllOVH As Integer = 4
    
    Sub ActivitiesForecasts()
         '    'This is the Direct Activities routine
         '    'It calls the Direct Activities, Enhancements, Indirect Activities, Overheads and Projects routine with the Indirect Activities option
        Call ForecastsExtract(nUseAllDIR)
        Call ForecastsExtract(nUseAllEH)
        Call ForecastsExtract(nUseAllIND)
        Call ForecastsExtract(nUseAllOVH)
    End Sub
    
     Sub ForecastsExtract(iOption As Integer)
        
        Dim a
        Dim ad As Worksheet
        Dim bottomB As Integer
        Dim dic As Object
        Dim i As Long
        Dim Mmonth
        Dim rng As Range
        Dim ws As Worksheet
        Dim Y()
        
        Application.ScreenUpdating = False
        
        Set ad = Sheets("All Data")
        
        bottomB = Range("B" & Rows.Count).End(xlUp).Row
        For Each rng In ad.Range("B8:B" & bottomB)
            If rng > 0 Then
                Set ws = Sheets(rng.Value)
                
                Application.ScreenUpdating = False
                
                With Worksheets("All Data")
                    a = .Range("B8").CurrentRegion ' Load the required range in to array, named "a"
                End With
                
                Set dic = CreateObject("scripting.dictionary")
                dic.comparemode = 1
                            
                With dic
                    For i = 2 To UBound(a) ' Loop through rows
                    
                     Select Case iOption
                      Case nUseAllDIR
                        If a(i, 1) = ws.Name And InStr(a(i, 8), "TM - DIR") > 0 Then 'test if column C is "Consultancy & Requirements"
                            Mmonth = Trim(Format(a(i, 12), "mmm yy")) ' format the date in to mmm-yy
                            If Not .exists(Mmonth) Then 'If column C cells do not exist, load column E value in to dictionary using column C as item
                                .Item(Mmonth) = a(i, 14)
                            Else
                                .Item(Mmonth) = .Item(Mmonth) + a(i, 14) 'If column C cells do exist, then add column E in to existing item
                            End If
                        End If
                         Case nUseAllEH
                         If a(i, 1) = ws.Name And InStr(a(i, 8), "Enhancements") > 0 Then 'test if column C is "Consultancy & Requirements"
                            Mmonth = Trim(Format(a(i, 12), "mmm yy")) ' format the date in to mmm-yy
                            If Not .exists(Mmonth) Then 'If column C cells do not exist, load column E value in to dictionary using column C as item
                                .Item(Mmonth) = a(i, 14)
                            Else
                                .Item(Mmonth) = .Item(Mmonth) + a(i, 14) 'If column C cells do exist, then add column E in to existing item
                            End If
                        End If
                         Case nUseAllIND
                         If a(i, 1) = ws.Name And InStr(a(i, 8), "TM - IND") > 0 Then 'test if column C is "Consultancy & Requirements"
                            Mmonth = Trim(Format(a(i, 12), "mmm yy")) ' format the date in to mmm-yy
                            If Not .exists(Mmonth) Then 'If column C cells do not exist, load column E value in to dictionary using column C as item
                                .Item(Mmonth) = a(i, 14)
                            Else
                                .Item(Mmonth) = .Item(Mmonth) + a(i, 14) 'If column C cells do exist, then add column E in to existing item
                            End If
                        End If
                         Case nUseAllOVH
                         If a(i, 1) = ws.Name And InStr(a(i, 8), "TM - OVH") > 0 Then 'test if column C is "Consultancy & Requirements"
                            Mmonth = Trim(Format(a(i, 12), "mmm yy")) ' format the date in to mmm-yy
                            If Not .exists(Mmonth) Then 'If column C cells do not exist, load column E value in to dictionary using column C as item
                                .Item(Mmonth) = a(i, 14)
                            Else
                                .Item(Mmonth) = .Item(Mmonth) + a(i, 14) 'If column C cells do exist, then add column E in to existing item
                            End If
                        End If
                        End Select
                    Next
                End With
                
                With ws
                    a = .Range("C7", .Cells(7, .Columns.Count).End(xlToLeft)) ' Load the required range in to array, named "a"
                End With
                
                ReDim Y(1 To 2, 1 To UBound(a, 2))
                
                With dic
                    For i = 1 To UBound(a, 2) ' Loop through rows
                        Mmonth = Trim(Format(a(1, i), "mmm yy")) ' format the date in to mmm-yy
                        If .exists(Mmonth) Then 'If column C cells do exist then copy the the dictionary in to match column
                            Y(1, i) = .Item(Mmonth)
                        End If
                    Next
                End With
                
                With ws
                         'Process either Direct Activities, Enhancements, Indirect Activities, Overheads or PROJECTS for resize
                        Select Case iOption
    
                             'Direct Activities processing resize
                        Case nUseAllDIR
                            .Range("C9").Resize(1, i - 1) = Y() 'Result-load Y in to C8
    
                             'Enhancements processing resize
                        Case nUseAllEH
                            .Range("C10").Resize(1, i - 1) = Y() 'Result-load Y in to C8
    
                             'Indirect Activities processing resize
                        Case nUseAllIND
                            .Range("C11").Resize(1, i - 1) = Y() 'Result-load Y in to C8
    
                             'Overheads processing resize
                        Case nUseAllOVH
                            .Range("C12").Resize(1, i - 1) = Y() 'Result-load Y in to C8
                        End Select
                    End With
            End If
        Next rng
        Set dic = Nothing ' clear dic
    End Sub

Sub CopyRows()
    Dim LastRow As Long
    Dim destRng As Range
    Application.ScreenUpdating = False
    With Sheets("Combined")
        Set destRng = .Range("B" & .Cells(.Rows.Count, "B").End(xlUp).Row + 1)
        LastRow = Sheets("Monthly").Range("C" & Rows.Count).End(xlUp).Row
        Sheets("Monthly").Range("B8:S" & LastRow).Copy Destination:=destRng
        .Columns("B:S").AutoFit
    End With
End Sub

Sub AllDataSignals3()
    
    Dim Dic As Object
    Dim Dn As Range
    Dim Rng As Range
    'The section of code below looks in column D on the "All Resources" (Source sheet)
    With Sheets("All Resources")
        Set Rng = .Range(.Range("D8"), .Range("D" & Rows.Count).End(xlUp))
    End With
    
    'The section of code below then looks in column G on the 'Source' sheet and stores that value.
    Set Dic = CreateObject("scripting.dictionary")
    Dic.CompareMode = vbTextCompare
    For Each Dn In Rng
        Set Dic(Dn & Dn.Offset(, 3)) = Dn
    Next
    
    'The section of code below then looks in column E on the "All Data" (Destination sheet)
    With Sheets("All Data")
        'This the column on the 'Destination' sheet you are comparing to the 'Source' sheet.
        Set Rng = .Range(.Range("E8"), .Range("E" & Rows.Count).End(xlUp))
    End With
    
    'The first two lines below then searches column M on the 'Destination' sheet and stores that value.
    For Each Dn In Rng
        If Dic.exists(Dn & Dn.Offset(, 8)) Then
            'Where the values stored in the 'Dictionary' variable match, the values from column H are copied and paste into column H on the 'Destination' sheet.
            'The first offset is the 'Destination' sheet i.e. 3 columns from column E.
            'The middle offset is the value being checked in column M i.e. 8 columns from column E on the Destination' sheet.
            'The last offset is the 'Source' sheet i.e. 4 columns from column d.
            Dn.Offset(, 3).Value = Dic.Item(Dn & Dn.Offset(, 8)).Offset(, 4).Value
        End If
        Next Dn
    End Sub