Posts by ashu1990

Private Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, Cancel As Boolean)
Dim rng1 As Range
Dim rng2 As Range
On Error Resume Next
Set rng1 = Intersect(Cells.SpecialCells(xlFormulas), Cells.SpecialCells(xlBlanks))
Set rng2 = Intersect(Cells.SpecialCells(xlConstants), Cells.SpecialCells(xlBlanks))
On Error GoTo 0
ActiveSheet.UsedRange.Locked = False
If Not rng1 Is Nothing Then rng1.Locked = True
If Not rng2 Is Nothing Then rng2.Locked = True
ActiveSheet.Protect "Password"
End Sub

Sub TestVBA()
'// Just change the file to test here
Const strFileToOpen As String = "Cata.xls"
If IsFileOpen(strFileToOpen) Then
MsgBox strFileToOpen & " is already Open" & _
vbCrLf & "By " & LastUser(strFileToOpen), vbInformation, "File in Use"
Else
MsgBox strFileToOpen & " is not open", vbInformation
End If
End Sub
Function IsFileOpen(strFullPathFileName As String) As Boolean
Dim hdlFile As Long


On Error GoTo FileIsOpen:
hdlFile = FreeFile
Open strFullPathFileName For Random Access Read Write Lock Read Write As hdlFile
IsFileOpen = False
Close hdlFile
Exit Function
FileIsOpen:
'// Someone has it open!
IsFileOpen = True
Close hdlFile
End Function
Private Function LastUser(strPath As String) As String
Dim strXl As String
Dim strFlag1 As String, strflag2 As String
Dim i As Integer, j As Integer
Dim hdlFile As Long
Dim lNameLen As Byte


strFlag1 = Chr(0) & Chr(0)
strflag2 = Chr(32) & Chr(32)
hdlFile = FreeFile
Open strPath For Binary As #hdlFile
strXl = Space(LOF(hdlFile))
Get 1, , strXl
Close #hdlFile
j = InStr(1, strXl, strflag2)
#If Not VBA6 Then
'// Xl97
For i = j - 1 To 1 Step -1
If Mid(strXl, i, 1) = Chr(0) Then Exit For
Next
i = i + 1
#Else
'// Xl2000+
i = InStrRev(strXl, strFlag1, j) + Len(strFlag1)
#End If
'// IFM
lNameLen = Asc(Mid(strXl, i - 3, 1))
LastUser = Mid(strXl, i, lNameLen)
End Function

Sub test()
Dim cnt As Double




cnt = WorksheetFunction.RoundDown(WorksheetFunction.CountA(Range("A:A")) / 2, 0)


Range("A:C").Interior.Color = xlNone


With Range("A1:C" & cnt).Interior
        .Pattern = xlSolid
        .PatternColorIndex = xlAutomatic
        .ThemeColor = xlThemeColorAccent6
        .TintAndShade = 0.799981688894314
        .PatternTintAndShade = 0
End With




End Sub

Option Explicit
Sub test()
    Dim wbk As Workbook, path As String, i As Long, fname As String, cell As Variant, font_cri As String
    path = ActiveSheet.Range("B3").Value '<--- Path of the folder
    font_cri = ActiveSheet.Range("C3").Value
     
    ThisWorkbook.Worksheets("Font Checker").usedrange.ClearContents
     
    fname = Dir(path & "\", vbNormal)
    
    Do While fname <> ""
    
        Set wbk = Workbooks.Open(path & "\" & fname)
        For i = 1 To wbk.Worksheets.Count
             
            For Each cell In wbk.Worksheets(i).UsedRange
                 
                If cell.Font.Name <> font_cri Then
                     
                    With ThisWorkbook.Worksheets("Font Checker")
                         
                        .Range("A" & Range("A:A").Rows.Count).End(xlUp).Offset(1, 0).Value = wbk.FullName
                        .Range("B" & Range("B:B").Rows.Count).End(xlUp).Offset(1, 0).Value = wbk.Worksheets(i).Name
                        .Range("C" & Range("C:C").Rows.Count).End(xlUp).Offset(1, 0).Value = cell.Address(0, 0) & "-" & cell.Value & "- Arial Font Is Not Matching"
                         
                    End With
                     
                End If
                 
            Next cell
             
        Next i
         
        wbk.Close False
        
        fname = Dir()
    Loop
    
    ThisWorkbook.Worksheets("Font Checker").Range("A1").Value = "File Name"
    ThisWorkbook.Worksheets("Font Checker").Range("B1").Value = "Sheet Name"
    ThisWorkbook.Worksheets("Font Checker").Range("C1").Value = "cell Value and address"
End Sub