I'm quite new to VBA but basically, I am have 4 excel sheet in the same directory they have identical headers, just differ in values, I am trying to compare them and retrieve the results on the current excel sheet where I run my VBA command. At the same time, there's unnecessary rows I won't need and want it to be removed. Basically the algorithm and calculation works. Because I have logged it and I checked it works. However, the comparison outcome is not showing. Every time I run this command it just generate a log but my current excel is still blank. Can someone advise me what I am doing wrong.
Option Explicit
Sub CompareAndModifyFiles()
' Disable unnecessary Excel settings for performance
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Application.EnableEvents = False
On Error Resume Next
Dim filePath As String
Dim logFilePath As String
Dim logFileNumber As Integer
Dim wbA As Workbook, wbB As Workbook, wbC As Workbook, wbD As Workbook
Dim wsA As Worksheet, wsB As Worksheet, wsC As Worksheet, wsD As Worksheet
Dim i As Long
Dim dataA As Variant, dataB As Variant, dataC As Variant, dataD As Variant
Dim maxVal As Variant, minVal As Variant, avgVal As Variant
Dim columnToCheck As Long
' Set the file path
filePath = "C:\Users\kelvin.how\Downloads\"
logFilePath = filePath & "Log.txt"
' Open or create the log file
logFileNumber = FreeFile
Open logFilePath For Output As logFileNumber
' Log the start of the operation
LogMessage logFileNumber, "Comparison and Modification Operation - Start: " & Format(Now(), "yyyy-mm-dd hh:mm:ss")
' Open each workbook
Set wbA = Workbooks.Open(filePath & "a.xlsx")
Set wbB = Workbooks.Open(filePath & "b.xlsx")
Set wbC = Workbooks.Open(filePath & "c.xlsx")
Set wbD = Workbooks.Open(filePath & "d.xlsx")
' Loop through each sheet in each workbook
For Each wsA In wbA.Sheets
Set wsB = GetSheetIfExists(wbB, wsA.Name)
Set wsC = GetSheetIfExists(wbC, wsA.Name)
Set wsD = GetSheetIfExists(wbD, wsA.Name)
' Check if corresponding sheets exist in all workbooks
If Not (wsB Is Nothing) And Not (wsC Is Nothing) And Not (wsD Is Nothing) Then
' Read data into arrays
dataA = wsA.UsedRange.Value
dataB = wsB.UsedRange.Value
dataC = wsC.UsedRange.Value
dataD = wsD.UsedRange.Value
' Delete specified columns
dataA = DeleteColumnsFromArray(dataA, Array(2, 3, 4, 8, 9, 10, 11, 15, 16, 20, 21, 22, 23, 24, 25, 26, 27, 28, 29, 30, _
31, 32, 33, 34, 35, 39, 40, 41, 42, 43, 44, 45, 46, 47, 48, 49, 50, 51, _
52, 53, 54, 55, 56, 57))
' Loop through each row in the specified range
For i = 2 To UBound(dataA, 1)
' Compare values and modify accordingly
For columnToCheck = LBound(dataA, 2) To UBound(dataA, 2)
If columnToCheck <= UBound(dataB, 2) And _
columnToCheck <= UBound(dataC, 2) And _
columnToCheck <= UBound(dataD, 2) Then
maxVal = Application.WorksheetFunction.Max(dataA(i, columnToCheck), _
dataB(i, columnToCheck), _
dataC(i, columnToCheck), _
dataD(i, columnToCheck))
minVal = Application.WorksheetFunction.Min(dataA(i, columnToCheck), _
dataB(i, columnToCheck), _
dataC(i, columnToCheck), _
dataD(i, columnToCheck))
avgVal = Application.WorksheetFunction.Average(dataA(i, columnToCheck), _
dataB(i, columnToCheck), _
dataC(i, columnToCheck), _
dataD(i, columnToCheck))
' Modify the data in the array
If maxVal = minVal And minVal = avgVal Then
LogMessage logFileNumber, "Row " & i & ", Column " & columnToCheck & ": Values are the same across all workbooks"
Else
' Values differ, modify accordingly
LogMessage logFileNumber, "Row " & i & ", Column " & columnToCheck & ": Values differ - Max: " & maxVal & ", Min: " & minVal & ", Avg: " & avgVal
dataA(i, columnToCheck) = IIf(columnToCheck = 37, IIf(IsNumeric(avgVal), avgVal, ""), _
IIf(columnToCheck = 38, IIf(IsNumeric(minVal), minVal, ""), _
IIf(columnToCheck = 39, IIf(IsNumeric(maxVal), maxVal, ""), "")))
End If
End If
Next columnToCheck
Next i
' Write modified data back to the worksheet
wsA.UsedRange.Value = dataA
Else
LogMessage logFileNumber, "Sheets not found in all workbooks: " & wsA.Name
End If
Next wsA
' Close workbooks without saving changes
wbA.Close SaveChanges:=False
wbB.Close SaveChanges:=False
wbC.Close SaveChanges:=False
wbD.Close SaveChanges:=False
' Log the end of the operation
LogMessage logFileNumber, "Comparison and Modification Operation - End: " & Format(Now(), "yyyy-mm-dd hh:mm:ss")
' Close the log file
Close logFileNumber
' Enable Excel settings
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
Application.EnableEvents = True
End Sub
Sub LogMessage(logFileNumber As Integer, message As String)
' Alternative log message function
Print #logFileNumber, message
Debug.Print message ' This will also print the message to the immediate window for debugging purposes
End Sub
Function GetSheetIfExists(wb As Workbook, sheetName As String) As Worksheet
On Error Resume Next
Set GetSheetIfExists = wb.Sheets(sheetName)
On Error GoTo 0
End Function
Function GetNumericValue(value As Variant) As Variant
' Modified to return actual numeric values
If IsNumeric(value) Then
GetNumericValue = value
Else
GetNumericValue = 0 ' Change this to whatever default numeric value you want
End If
End Function
Function DeleteColumnsFromArray(dataArray As Variant, columnsToDelete As Variant) As Variant
Dim i As Long, j As Long
Dim newDataArray As Variant
ReDim newDataArray(1 To UBound(dataArray, 1), 1 To UBound(dataArray, 2) - UBound(columnsToDelete))
For i = LBound(dataArray, 1) To UBound(dataArray, 1)
For j = LBound(dataArray, 2) To UBound(dataArray, 2)
If Not IsInArray(j, columnsToDelete) Then
newDataArray(i, j - (j > UBound(columnsToDelete))) = dataArray(i, j)
End If
Next j
Next i
DeleteColumnsFromArray = newDataArray
End Function
Function IsInArray(value As Variant, arr As Variant) As Boolean
Dim i As Long
For i = LBound(arr) To UBound(arr)
If arr(i) = value Then
IsInArray = True
Exit Function
End If
Next i
End Function
Solved. Simply create multiple buttons with macro performing separate different individual calculations and algorithms for each buttons.
i.e. Button for ECS
Sub ECS()
Dim wsCurrent As Worksheet
Dim wsSource As Worksheet
Dim lastRow As Long
' Set the current worksheet
Set wsCurrent = ThisWorkbook.ActiveSheet
' Open the source workbook
Dim sourceFilePath As String
sourceFilePath = "C:\Users\kelvin.how\Downloads\a.xlsx"
Workbooks.Open sourceFilePath
Set wsSource = Workbooks("a.xlsx").Worksheets(1) ' Assuming data is on the first sheet
' Find the last row in column A of the source worksheet
lastRow = wsSource.Cells(wsSource.Rows.Count, "A").End(xlUp).Row
' Copy data from A4 to the last row in column A of the source worksheet
wsSource.Range("A4:A" & lastRow).Copy
wsCurrent.Range("A3").PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
' Copy data from D4 to the last row in column D of the source worksheet
wsSource.Range("D4:D" & lastRow).Copy
wsCurrent.Range("B3").PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
' Copy data from E4 to the last row in column E of the source worksheet
wsSource.Range("E4:E" & lastRow).Copy
wsCurrent.Range("C3").PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
' Copy data from F4 to the last row in column F of the source worksheet
wsSource.Range("F4:F" & lastRow).Copy
wsCurrent.Range("D3").PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
' Copy data from G4 to the last row in column G of the source worksheet
wsSource.Range("G4:G" & lastRow).Copy
wsCurrent.Range("E3").PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
' Close the source workbook without saving changes
Workbooks("a.xlsx").Close SaveChanges:=False
End Sub
Button for CPU
Sub CPU()
Dim path As String
Dim files As Variant
Dim wb As Workbook
Dim ws As Worksheet
Dim lastRow As Long
Dim i As Integer
Dim j As Long
' Set the path to the directory containing the files
path = "C:\Users\kelvin.how\Downloads\"
' List of file names to compare
files = Array("a.xlsx", "b.xlsx", "c.xlsx", "d.xlsx")
' Set up the main workbook and worksheet
Set wb = ThisWorkbook ' Assuming the macro is in the workbook where you want to copy data
Set ws = wb.Sheets(1) ' Assuming data is on the first sheet
' Loop through each file
For i = 0 To UBound(files)
' Open each workbook
Set externalWb = Workbooks.Open(path & files(i))
' Find the last row in column L, M, and N
lastRow = externalWb.Sheets(1).Cells(externalWb.Sheets(1).Rows.Count, "L").End(xlUp).Row
' Compare and copy data from column L to column F
For j = 4 To lastRow
ws.Cells(j - 1, "F").Value = Application.WorksheetFunction.Max(ws.Cells(j - 1, "F").Value, externalWb.Sheets(1).Cells(j, "L").Value)
Next j
' Initialize minimum value in column G
For j = 4 To lastRow
ws.Cells(j - 1, "G").Value = IIf(i = 0, externalWb.Sheets(1).Cells(j, "M").Value, _
Application.WorksheetFunction.Min(ws.Cells(j - 1, "G").Value, externalWb.Sheets(1).Cells(j, "M").Value))
Next j
' Accumulate values for average calculation
For j = 1 To lastRow - 3
ws.Cells(j + 2, "H").Value = (ws.Cells(j + 2, "H").Value * i + externalWb.Sheets(1).Cells(j + 3, "N").Value) / (i + 1)
Next j
' Close the external workbook
externalWb.Close SaveChanges:=False
Next i
End Sub
Button for Memory
Sub Memory()
Dim path As String
Dim files As Variant
Dim wb As Workbook
Dim ws As Worksheet
Dim lastRow As Long
Dim i As Integer
Dim j As Long
' Set the path to the directory containing the files
path = "C:\Users\kelvin.how\Downloads\"
' List of file names to compare
files = Array("a.xlsx", "b.xlsx", "c.xlsx", "d.xlsx")
' Set up the main workbook and worksheet
Set wb = ThisWorkbook ' Assuming the macro is in the workbook where you want to copy data
Set ws = wb.Sheets(1) ' Assuming data is on the first sheet
' Loop through each file
For i = 0 To UBound(files)
' Open each workbook
Set externalWb = Workbooks.Open(path & files(i))
' Find the last row in column Q, R, and S
lastRow = externalWb.Sheets(1).Cells(externalWb.Sheets(1).Rows.Count, "Q").End(xlUp).Row
' Compare and copy data from column Q to column I
For j = 4 To lastRow
ws.Cells(j - 1, "I").Value = Application.WorksheetFunction.Max(ws.Cells(j - 1, "I").Value, externalWb.Sheets(1).Cells(j, "Q").Value)
Next j
' Compare and copy data from column R to column J
For j = 4 To lastRow
If i = 0 Then
ws.Cells(j - 1, "J").Value = externalWb.Sheets(1).Cells(j, "R").Value
Else
ws.Cells(j - 1, "J").Value = Application.WorksheetFunction.Min(ws.Cells(j - 1, "J").Value, externalWb.Sheets(1).Cells(j, "R").Value)
End If
Next j
' Calculate average data from column S to column K
For j = 4 To lastRow
ws.Cells(j - 1, "K").Value = (ws.Cells(j - 1, "K").Value * i + externalWb.Sheets(1).Cells(j, "S").Value) / (i + 1)
Next j
' Close the external workbook
externalWb.Close SaveChanges:=False
Next i
End Sub
Button for Total
Sub Total()
Dim path As String
Dim wb As Workbook
Dim ws As Worksheet
Dim lastRow As Long
Dim j As Long
Dim afValue As Double
Dim akValue As Double
Dim result As Double
' Set the path to the directory containing the file
path = "C:\Users\kelvin.how\Downloads\"
' Set up the main workbook and worksheet
Set wb = ThisWorkbook ' Assuming the macro is in the workbook where you want to copy data
Set ws = wb.Sheets(1) ' Assuming data is on the first sheet
' Open the workbook for calculation
Set externalWb = Workbooks.Open(path & "a.xlsx")
' Find the last row in column AF and AK
lastRow = externalWb.Sheets(1).Cells(externalWb.Sheets(1).Rows.Count, "AF").End(xlUp).Row
' Perform the calculation and copy the rounded-up values to column L
For j = 4 To lastRow
afValue = externalWb.Sheets(1).Cells(j, "AF").Value
akValue = externalWb.Sheets(1).Cells(j, "AK").Value
' Check if AK is greater than zero before performing the calculation
If akValue > 0 Then
result = WorksheetFunction.Ceiling(afValue / (akValue / 100), 10)
Else
' If AK is zero or negative, set the result to zero
result = 0
End If
' Copy the result to column L
ws.Cells(j - 1, "L").Value = result
Next j
' Close the external workbook
externalWb.Close SaveChanges:=False
End Sub
Button for Storage
Sub Storage()
Dim path As String
Dim files As Variant
Dim wb As Workbook
Dim ws As Worksheet
Dim lastRow As Long
Dim i As Integer
Dim j As Long
' Set the path to the directory containing the files
path = "C:\Users\kelvin.how\Downloads\"
' List of file names to compare
files = Array("a.xlsx", "b.xlsx", "c.xlsx", "d.xlsx")
' Set up the main workbook and worksheet
Set wb = ThisWorkbook ' Assuming the macro is in the workbook where you want to copy data
Set ws = wb.Sheets(1) ' Assuming data is on the first sheet
' Loop through each file
For i = 0 To UBound(files)
' Open each workbook
Set externalWb = Workbooks.Open(path & files(i))
' Find the last row in column AK, AL, and AM
lastRow = externalWb.Sheets(1).Cells(externalWb.Sheets(1).Rows.Count, "AK").End(xlUp).Row
' Compare and copy data from column AK to column M
For j = 4 To lastRow
ws.Cells(j - 1, "M").Value = Application.WorksheetFunction.Max(ws.Cells(j - 1, "M").Value, externalWb.Sheets(1).Cells(j, "AK").Value)
Next j
' Initialize minimum value in column N
For j = 4 To lastRow
If i = 0 Then
ws.Cells(j - 1, "N").Value = externalWb.Sheets(1).Cells(j, "AL").Value
Else
ws.Cells(j - 1, "N").Value = Application.WorksheetFunction.Min(ws.Cells(j - 1, "N").Value, externalWb.Sheets(1).Cells(j, "AL").Value)
End If
Next j
' Initialize values for average calculation in column O
For j = 4 To lastRow
ws.Cells(j - 1, "O").Value = ws.Cells(j - 1, "O").Value + externalWb.Sheets(1).Cells(j, "AM").Value
Next j
' Close the external workbook
externalWb.Close SaveChanges:=False
Next i
' Calculate average values in column O
For j = 4 To lastRow
ws.Cells(j - 1, "O").Value = ws.Cells(j - 1, "O").Value / (UBound(files) + 1)
Next j
End Sub