Sub ProcessExtractedFile()
On Error GoTo ErrorHandler
Dim destFolder As String
Dim extractedFilePath As String
Dim openedWorkbook As Workbook
Dim newFileName As String
Dim ws As Worksheet
Dim lastColumn As Long
Dim columnCounter As Long
Dim password As String
Dim amountColumn As Long
Dim fileCount As Integer
Set ws = ThisWorkbook.Sheets(1)
' Get the destination folder path from cell A2
destFolder = ws.Shapes("TextBox1").TextFrame.Characters.Text
' Count the number of files matching the pattern
extractedFilePath = Dir(destFolder & "\*.xls*")
Do While extractedFilePath <> ""
fileCount = fileCount + 1
extractedFilePath = Dir
Loop
' Check if more than one file matches the pattern
If fileCount > 1 Then
MsgBox "Error: Multiple files found in the destination folder. Please ensure path is empty.", vbCritical, "Invalid Destination Folder"
Exit Sub
End If
' Check if cell A3 (password) is blank
password = ws.Shapes("TextBox2").TextFrame.Characters.Text
If Len(password) = 0 Then
Dim proceed As VbMsgBoxResult
proceed = MsgBox("Warning: Password is blank. Do you want to Proceed?", vbYesNo + vbQuestion)
If proceed <> vbYes Then
MsgBox "Processing Aborted.", vbInformation
Exit Sub
End If
End If
' Select a file with a specific name pattern that includes today's date
extractedFilePath = destFolder & "\" & Dir(destFolder & "\*.xls*")
' Open the Excel file from the extracted folder
On Error Resume Next
Set openedWorkbook = Workbooks.Open(extractedFilePath)
On Error GoTo 0
' Check for errors
If openedWorkbook Is Nothing Then
MsgBox "Error opening the ExtractedFile. Please check Zip file and process again.", vbExclamation
Exit Sub
End If
' Set the number format of the entire sheet to text "@"
openedWorkbook.ActiveSheet.Cells.NumberFormat = "@"
' Set font and font size for the entire sheet
openedWorkbook.ActiveSheet.Cells.Font.Name = "Calibri Light"
openedWorkbook.ActiveSheet.Cells.Font.Size = 11
' Set font size for the first row
openedWorkbook.ActiveSheet.Rows(1).Font.Size = 12
' Auto fit column width for all columns
openedWorkbook.ActiveSheet.Cells.EntireColumn.AutoFit
' Find the last column in the used range
lastColumn = openedWorkbook.ActiveSheet.UsedRange.Columns.Count
' Loop through each column and apply Text to Columns
For columnCounter = 1 To lastColumn
openedWorkbook.ActiveSheet.Columns(columnCounter).TextToColumns _
Destination:=openedWorkbook.ActiveSheet.Cells(1, columnCounter), _
DataType:=xlDelimited, TextQualifier:=xlDoubleQuote, _
ConsecutiveDelimiter:=True, Tab:=True, Semicolon:=False, _
Comma:=False, Space:=False, Other:=False, FieldInfo:=Array(1, 2), _
TrailingMinusNumbers:=True
Next columnCounter
' Find the column with "Amount" or "Amt" in the header
Dim found As Range
Set found = openedWorkbook.ActiveSheet.Rows(1).Find(What:="*Amount*", LookIn:=xlValues, LookAt:=xlPart)
If found Is Nothing Then Set found = openedWorkbook.ActiveSheet.Rows(1).Find(What:="*Amt*", LookIn:=xlValues, LookAt:=xlPart)
If Not found Is Nothing Then
amountColumn = found.Column
' Convert values in the found column to numbers and round to 2 decimal places
Dim lastRow As Long
lastRow = openedWorkbook.ActiveSheet.Cells(openedWorkbook.ActiveSheet.Rows.Count, amountColumn).End(xlUp).Row
Dim cell As Range
For Each cell In openedWorkbook.ActiveSheet.Range(openedWorkbook.ActiveSheet.Cells(2, amountColumn), openedWorkbook.ActiveSheet.Cells(lastRow, amountColumn))
If IsNumeric(cell.Value) Then
cell.Value = Round(cell.Value, 2)
cell.NumberFormat = "0.00"
End If
Next cell
End If
' Find the last column in the used range
lastColumn = openedWorkbook.ActiveSheet.UsedRange.Columns.Count
' Apply formatting only to the used range in the header row
With openedWorkbook.ActiveSheet.Range(openedWorkbook.ActiveSheet.Cells(1, 1), openedWorkbook.ActiveSheet.Cells(1, lastColumn))
' Set the background color to white
.Interior.Color = RGB(255, 255, 255)
.Interior.Color = RGB(221, 221, 221) ' 15% darkness
' Apply continuous borders around each cell in the range
.Borders.LineStyle = xlContinuous
.Borders.Color = RGB(0, 0, 0) ' Black color for borders
' Middle Align & Align Center
.VerticalAlignment = xlCenter
.HorizontalAlignment = xlCenter
End With
' Apply formatting to the rest of the rows for Middle Align & Align Left
With openedWorkbook.ActiveSheet.Rows("2:" & openedWorkbook.ActiveSheet.Rows.Count)
' Middle Align & Align Left
.VerticalAlignment = xlCenter
.HorizontalAlignment = xlLeft
End With
Dim rng As Range
Dim cell As Range
Dim del As Range
' Loop through each row in the worksheet
For Each rng In openedWorkbook.ActiveSheet.Rows
If Application.CountA(rng) = 0 Then
If del Is Nothing Then
Set del = rng
Else: Set del = Union(del, rng)
End If
End If
Next rng
' Delete blank rows if found
If Not del Is Nothing Then del.Delete
' Reset the variable for columns deletion process
Set del = Nothing
' Loop through each column in the worksheet
For Each rng In openedWorkbook.ActiveSheet.Columns
If Application.CountA(rng) = 0 Then
If del Is Nothing Then
Set del = rng
Else: Set del = Union(del, rng)
End If
End If
Next rng
' Delete blank columns if found
If Not del Is Nothing Then del.Delete
' Protect the active sheet with a password
If Len(password) > 0 Then
openedWorkbook.ActiveSheet.Protect password:=password
End If
' Generate a new file name with today's date and time
newFileName = "Generated_From_Macro_" & Format(Now, "DDMMYYYY_HHMMSS") & ".xls"
' Save the file as an Excel 97-2003 Workbook (*.xls)
openedWorkbook.SaveAs destFolder & "\" & newFileName, FileFormat:=xlExcel8
' Close the original workbook without saving changes
openedWorkbook.Close savechanges:=False
MsgBox "Processing Completed Successfully!", vbInformation
Exit Sub
ErrorHandler:
MsgBox "Error: If your are continuosly facing this error, Please Contact Author of this Macro", vbExclamation, "Author (Samarth Salunkhe)"
End Sub
