Posts by dangle

Sub ListFoldersAndInfo(foldername As String, Destination As Range)
    Dim FSO As Object
    Dim Folder As Object
    Dim R As Long
    Dim SubFolder As Object
    Dim Wks As Worksheet
    Dim str As String
    
    Set FSO = CreateObject("Scripting.FileSystemObject")
    Set Folder = FSO.GetFolder(foldername)
    Destination = Folder.Name
    
    str = Destination.Value
    If str Like "Video*" Then
        On Error Resume Next
        Destination = Left(str, InStr(1, str, " ") - 1)
        Destination.Offset(0, 1) = Mid(str, InStr(str, "(") + 1, 4)
    End If
    
    Destination.Offset(0, 2) = Folder.Size
    Set Destination = Destination.Offset(1, 0)
     
    For Each SubFolder In Folder.SubFolders
        ListFoldersAndInfo Folder.Path & "\" & SubFolder.Name, Destination
    Next SubFolder
     
    Set FSO = Nothing
     
End Sub

Sub FindDuplicates()


Dim FilterRange As Range
Dim UniqueList As Range
Dim UniqueList2 As Range
Dim RowCount As Long
Dim LoopCell As Range
Dim lCount As Long
Dim wksSource As Worksheet


Set wksSource = ActiveSheet
Application.ScreenUpdating = False
If (wksSource.AutoFilterMode) Then wksSource.AutoFilterMode = False
Range("V2") = "No. of subject occurrences"
Range("W2") = "Do duplicates exist?"
Range("X2") = "How many unique entries?"
Set FilterRange = Range("O2", Range("O2").End(xlDown))
Range(FilterRange.Address).AdvancedFilter Action:=xlFilterCopy, CopyToRange:=Range("U2" _
        ), Unique:=True
Set UniqueList = Range("U3", Range("U3").End(xlDown))


For Each LoopCell In UniqueList
    lCount = WorksheetFunction.CountIf(FilterRange, LoopCell.Value)
    LoopCell.Offset(0, 1).Value = lCount
    
    With Range("A2:S274")
    .AutoFilter Field:=15, Criteria1:=LoopCell.Value, Operator:=xlAnd
    .Copy Destination:=Range("Z2")
    End With
    
    If Range("AA4").Value = "" Then
        LoopCell.Offset(0, 2).Value = "NO"
        LoopCell.Offset(0, 3).Value = 1
    Else
        Set UniqueList2 = Range("AA2", Range("AA2").End(xlDown))
        Range(UniqueList2.Address).AdvancedFilter Action:=xlFilterCopy, CopyToRange:=Range("AB2" _
        ), Unique:=True
        RowCount = Range("AB3", Range("AB3").End(xlDown)).Rows.Count
        If RowCount <> lCount Then
            LoopCell.Offset(0, 2).Value = "YES"
            LoopCell.Offset(0, 3).Value = RowCount
        Else
            LoopCell.Offset(0, 2).Value = "NO"
            LoopCell.Offset(0, 3).Value = lCount
        End If
    End If
    
    Columns("Z:AB").Delete
    
Next LoopCell
wksSource.AutoFilterMode = False
Columns("U:X").EntireColumn.AutoFit
Application.ScreenUpdating = True


End Sub

Sub FindToday()


Dim DateRange As Range
Dim LoopCell As Range


Set DateRange = Range("A1", Range("A1").End(xlDown))


For Each LoopCell In DateRange
    If CDate(LoopCell.Value) = Format(Now, "dd/mm/yyyy") Then
    LoopCell.Activate
    Exit Sub
    End If
Next LoopCell


End Sub