Office Tools

Office: Tips and Tricks 





Function Replacement : 

MS Excel:

TEXT(WEEKNUM(DATE(YEAR(NOW()),MONTH(NOW()),

DAY(NOW())),1),"0") 

The above function returns Current Week Number in Test Format. 

Trimming whole sheet:

This macro trims the active sheet. When done a message box, telling "Trimming Finished" is shown. 

 Sub TrimSheetSmart()
Dim Row, Col, RowMax, ColMax As Integer

'RowMax = InputBox("Enter The Max Row Number :")
'ColMax = InputBox("Enter the Max Column Number :")
    Range("A1").Select
    ActiveCell.SpecialCells(xlLastCell).Select
    RowMax = ActiveCell.SpecialCells(xlLastCell).Row
    ColMax = ActiveCell.SpecialCells(xlLastCell).Column

For Col = 1 To ColMax
    For Row = 1 To RowMax
    'Cells(B, A) = Trim(Cells(B, A))
    
    Cells(Row, Col) = Trim(Cells(Row, Col))
    
Next Row
Next Col
MsgBox ("Triming Finished")

 

End Sub

 Generate the Summary of a Sheet:

 By summary, I mean, if Column A contains 100 values, from a,b,c,d,e,f,g,h,i, etc, then summary is the frequency of individual data. It add new sheet and put individual sheet summary.

This sheets generates the summary of a sheet. 


Sub SummarySheet()

    Dim ColumnName, DiffDataWithItr As String
    Dim TotalWorkSheets As Integer
    Dim RowIndex As Integer

    Dim Row, Col, RowMax, ColMax, i, DiffData As Integer
    Dim NewData As Boolean

    Dim ColumnContentArray() As Variant
    Dim ColumnContentArrayValue() As Variant




 Dim SheetCount As Integer
 
    
    Application.ScreenUpdating = True
    Application.DisplayAlerts = False
On Error GoTo Exits:
    Sheets.Add Type:="Worksheet"
    ActiveSheet.Name = "AA-SUMMARY"
    TotalWorkSheets = Worksheets.Count
   
    RowIndex = 1
    For SheetCount = 2 To TotalWorkSheets
       
       
   
    RowIndex = RowIndex + 1
    'Sheets(SheetCount).Range("A1").Select
    Sheets("AA-SUMMARY").Cells(RowIndex, 1) = Sheets(SheetCount).Name
    Sheets("AA-SUMMARY").Cells(RowIndex, 1).Font.Bold = True
   
   
    RowIndex = RowIndex + 2
'    Sheets(SheetCount).ActiveCell.SpecialCells(xlLastCell).Select
   ' ActiveCell.SpecialCells(xlLastCell).Select
    RowMax = Sheets(SheetCount).Cells.SpecialCells(xlLastCell).Row
    ColMax = Sheets(SheetCount).Cells.SpecialCells(xlLastCell).Column
DiffData = 0
For Col = 1 To ColMax - 1
For Row = 1 To RowMax - 1
    'Cells(Row, ColMax + 1) = Cells(Row, 1)
    If (Row = 1) Then
        If (Application.WorksheetFunction.CountA(Sheets(SheetCount).Cells(Row, Col)) = 0) Then
            'Cells(Row, ColMax + 1) = "NULL"
            ColumnName = "NULL"
        Else
            'Cells(Row, ColMax + 1) = Cells(Row, 4)
            ColumnName = Sheets(SheetCount).Cells(Row, Col)
        End If
    ElseIf (Row = 2) Then
   
        If (Application.WorksheetFunction.CountA(Sheets(SheetCount).Cells(Row, Col)) = 0) Then
                DiffData = DiffData + 1
                ReDim Preserve ColumnContentArray(1 To DiffData)
                ReDim Preserve ColumnContentArrayValue(1 To DiffData)
                ColumnContentArray(DiffData) = "NULL"
                ColumnContentArrayValue(DiffData) = 1
        Else
                DiffData = DiffData + 1
                ReDim Preserve ColumnContentArray(1 To DiffData)
                ReDim Preserve ColumnContentArrayValue(1 To DiffData)
                ColumnContentArray(DiffData) = Sheets(SheetCount).Cells(Row, Col)
                ColumnContentArrayValue(DiffData) = 1
        End If

           
   
    Else
        If (Application.WorksheetFunction.CountA(Sheets(SheetCount).Cells(Row, Col)) = 0) Then
       
            For i = 1 To DiffData
                If (ColumnContentArray(i) = "NULL") Then
                    NewData = False
                    ColumnContentArrayValue(i) = ColumnContentArrayValue(i) + 1
                    Exit For
                Else
                    NewData = True
                End If
            Next i
       
        'If (Row = RoxMax) Then
            If (NewData = True) Then
                DiffData = DiffData + 1
                ReDim Preserve ColumnContentArray(1 To DiffData)
                ReDim Preserve ColumnContentArrayValue(1 To DiffData)
                ColumnContentArray(DiffData) = "NULL"
                ColumnContentArrayValue(DiffData) = 1
            End If
        'End If
       
        Else
        For i = 1 To DiffData
            If (Sheets(SheetCount).Cells(Row, Col) = ColumnContentArray(i)) Then
                NewData = False
                ColumnContentArrayValue(i) = ColumnContentArrayValue(i) + 1
                Exit For
            Else
                NewData = True
            End If
        Next i
       
        'If (Row = RoxMax) Then
            If (NewData = True) Then
                DiffData = DiffData + 1
                ReDim Preserve ColumnContentArray(1 To DiffData)
                ReDim Preserve ColumnContentArrayValue(1 To DiffData)
                ColumnContentArray(DiffData) = Sheets(SheetCount).Cells(Row, Col)
                ColumnContentArrayValue(DiffData) = 1
            End If
        End If
    End If
    'End If
Next Row

For i = 1 To DiffData
    If (i = 1) Then
    DiffDataWithItr = ""
    End If
   
    DiffDataWithItr = DiffDataWithItr & ColumnContentArray(i) & "(" & ColumnContentArrayValue(i) & "); "
    'Cells(i + 1, ColMax + 1) = ColumnContentArray(i) & "( " & ColumnContentArrayValue(i) & " )"
    'Cells(i + 1, ColMax + 2) = ColumnContentArrayValue(i)
Next i
   
    Sheets("AA-SUMMARY").Cells(RowIndex, 1) = ColumnName & "(" & DiffData & ")"
    'RowIndex = RowIndex + 1
    Sheets("AA-SUMMARY").Cells(RowIndex, 2) = DiffDataWithItr
    RowIndex = RowIndex + 1
   
    ReDim ColumnContentArray(1)
    ReDim ColumnContentArrayValue(1)
    DiffData = 0
   
Next Col
    Next SheetCount
   
Sheets("AA-SUMMARY").Select
Sheets("AA-SUMMARY").Tab.ColorIndex = 35
            
    Columns("A:A").ColumnWidth = 20
    Columns("B:B").ColumnWidth = 127.29
    Columns("A:B").Select
    With Selection
        .HorizontalAlignment = xlGeneral
        .VerticalAlignment = xlBottom
        .WrapText = True
        .Orientation = 0
        .AddIndent = False
        .IndentLevel = 0
        .ShrinkToFit = False
        .ReadingOrder = xlContext
        .MergeCells = False
    End With

Sheets("AA-SUMMARY").Cells(1, 1).Select
'MsgBox "Processing Done!"
Exits:
    Application.ScreenUpdating = True
    Application.DisplayAlerts = True



End Sub