Code:
Rem 1 Worksheets info
Dim Ws As Worksheet: Set Ws = Me
Dim Rng As Range: Set Rng = Ws.Range("D2:F264")
Dim arrFiles() As Variant: Let arrFiles() = Rng.Value2
Rem 2 File extension types
Dim Ddl As Long, Sys As Long, Bin As Long, Cpa As Long, Vp As Long, Els As Long
Rem 3 Looping
Dim ClCnt As Long, RwCnt As Long
For RwCnt = 1 To UBound(arrFiles(), 1)
For ClCnt = 1 To UBound(arrFiles(), 2)
If arrFiles(RwCnt, ClCnt) = "" Then
' Empty cell, so do nothing
Else ' Time to look at cell value
If Left(arrFiles(RwCnt, ClCnt), 3) = "C:\" And InStr(4, arrFiles(RwCnt, ClCnt), ".", vbBinaryCompare) > 1 Then ' use some criteria to check we have a file path
' Get the extension
Dim Xtn As String
Let Xtn = Mid(arrFiles(RwCnt, ClCnt), (InStr(4, arrFiles(RwCnt, ClCnt), ".", vbBinaryCompare) + 1))
Select Case Xtn
Case "sys", "SYS"
Let Sys = Sys + 1
Case "dll"
Let Ddl = Ddl + 1
Case "bin"
Let Bin = Bin + 1
Case "cpa"
Let Cpa = Cpa + 1
Case "vp"
Let Vp = Vp + 1
Case Else
Debug.Print "Case Else " & arrFiles(RwCnt, ClCnt)
Let Els = Els + 1
End Select
Else ' not a file path
End If
End If
Next ClCnt
Next RwCnt
Rem 4 output
Debug.Print "sys " & Sys
Debug.Print "ddl " & Ddl
Debug.Print "bin " & Bin
Debug.Print "cpa " & Cpa
Debug.Print "vp " & Vp
Debug.Print "els " & Els
End Sub
Sub WotsANormalCellColor()
Let Range("A1").Value = "AnyText"
Debug.Print Range("A1").Font.Color & " " & Range("A1").Font.ColorIndex ' we seee that Color for black or automatic is 0 ColorIndex for black is 1 for automatic is -4105
End Sub
' The next code and the one in the next post is the spreadsheet type equivalent extended also to look at the color of the cells
Sub FileTypesHere()
Rem 1 Worksheets info
Dim Ws As Worksheet: Set Ws = Me
Dim Rng As Range: Set Rng = Ws.Range("D2:F264")
'Dim arrFiles() As Variant: Let arrFiles() = Rng.Value2
Rem 2 File extension types
Dim Ddl As Long, Sys As Long, Bin As Long, Cpa As Long, Vp As Long, Els As Long
Dim Ddl2 As Long, Sys2 As Long, Bin2 As Long, Cpa2 As Long, Vp2 As Long, Els2 As Long
Rem 3 Looping
'Dim ClCnt As Long, RwCnt As Long
Dim RngStr As Range ' a single cell to use as a stear element in the For Next loop
For Each RngStr In Rng
' For RwCnt = 1 To UBound(arrFiles(), 1)
' For ClCnt = 1 To UBound(arrFiles(), 2)
'If arrFiles(RwCnt, ClCnt) = "" Then
If RngStr.Value = "" Then
' Empty cell, so do nothing
Else ' Time to look at cell value
'If Left(arrFiles(RwCnt, ClCnt), 3) = "C:\" And InStr(4, arrFiles(RwCnt, ClCnt), ".", vbBinaryCompare) > 1 Then ' use some criteria to check we have a file path
If Left(RngStr.Value, 3) = "C:\" And InStr(4, RngStr.Value, ".", vbBinaryCompare) > 1 Then ' use some criteria to check we have a file path
' Get the extension
Dim Xtn As String
'Let Xtn = Mid(arrFiles(RwCnt, ClCnt), (InStr(4, arrFiles(RwCnt, ClCnt), ".", vbBinaryCompare) + 1))
Let Xtn = Mid(RngStr.Value, (InStr(4, RngStr.Value, ".", vbBinaryCompare) + 1))
Select Case Xtn
Case "sys", "SYS"
Let Sys = Sys + 1: If RngStr.Font.Color <> 0 Then Let Sys2 = Sys2 + 1
Case "dll"
Let Ddl = Ddl + 1: If RngStr.Font.Color <> 0 Then Let Ddl2 = Ddl2 + 1
Case "bin"
Let Bin = Bin + 1:: If RngStr.Font.Color <> 0 Then Let Bin2 = Bin2 + 1
Case "cpa"
Let Cpa = Cpa + 1: If RngStr.Font.Color <> 0 Then Let Cpa2 = Cpa2 + 1
Case "vp"
Let Vp = Vp + 1: If RngStr.Font.Color <> 0 Then Let Vp2 = Vp2 + 1
Case Else
Debug.Print "Case Else " & RngStr.Value
Let Els = Els + 1: If RngStr.Font.Color <> 0 Then Let Els2 = Els2 + 1
End Select
Else ' not a file path
End If
End If
' Next ClCnt
' Next RwCnt
Next RngStr
Rem 4 output
Debug.Print "sys " & Sys & " (" & Sys2 & ")"
Debug.Print "dll " & Ddl & " (" & Ddl2 & ")"
Debug.Print "bin " & Bin & " (" & Bin2 & ")"
Debug.Print "cpa " & Cpa & " (" & Cpa2 & ")"
Debug.Print "vp " & Vp & " (" & Vp2 & ")"
Debug.Print "els " & Els & " (" & Els2 & ")"
End Sub
Bookmarks