Sub SetupCoilTracking()
' Worksheet Setup
Dim ws As Worksheet
' Create or select the main tracking worksheet
On Error Resume Next
Set ws = ThisWorkbook.Sheets("Coil Tracking")
If ws Is Nothing Then
Set ws =
ThisWorkbook.Worksheets.Add(After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count))
ws.Name = "Coil Tracking"
End If
On Error GoTo 0
' Clear existing content
ws.Cells.Clear
' Set up headers for Coil Tracking
With ws
.Cells(1, 1).Value = "Coil ID"
.Cells(1, 2).Value = "Date Received"
.Cells(1, 3).Value = "Supplier"
.Cells(1, 4).Value = "Material Type"
.Cells(1, 5).Value = "Width"
.Cells(1, 6).Value = "Thickness"
.Cells(1, 7).Value = "Weight (kg)"
.Cells(1, 8).Value = "Status"
.Cells(1, 9).Value = "Notes"
' Format header row
.Range("A1:I1").Font.Bold = True
.Range("A1:I1").Interior.Color = RGB(200, 200, 200)
End With
' Create Comparison Worksheet
Dim compWs As Worksheet
On Error Resume Next
Set compWs = ThisWorkbook.Sheets("Coil Comparison")
If compWs Is Nothing Then
Set compWs =
ThisWorkbook.Worksheets.Add(After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count))
compWs.Name = "Coil Comparison"
End If
On Error GoTo 0
' Clear existing content in comparison sheet
compWs.Cells.Clear
' Set up headers for Comparison
With compWs
.Cells(1, 1).Value = "Comparison Type"
.Cells(1, 2).Value = "Coil ID 1"
.Cells(1, 3).Value = "Coil ID 2"
.Cells(1, 4).Value = "Difference"
.Cells(1, 5).Value = "Status"
' Format header row
.Range("A1:E1").Font.Bold = True
.Range("A1:E1").Interior.Color = RGB(180, 180, 250)
End With
' Create Validation for Coil Tracking Sheet
Call CreateCoilIDValidation(ws)
' Create Comparison Macro Button
Call CreateComparisonButton(compWs)
MsgBox "Coil Tracking and Comparison setup complete!", vbInformation
End Sub
' Create Data Validation for Coil ID
Sub CreateCoilIDValidation(ws As Worksheet)
' Ensure unique Coil ID
ws.Range("A2:A1048576").Validation.Delete
With ws.Range("A2:A1048576").Validation
.Add Type:=xlValidateTextLength, AlertStyle:=xlValidAlertStop, Operator:= _
xlBetween, Formula1:=1, Formula2:=50
.IgnoreBlank = True
.InCellDropdown = False
.InputTitle = "Coil ID"
.ErrorTitle = "Invalid Coil ID"
.InputMessage = "Enter a unique Coil ID (max 50 characters)"
.ErrorMessage = "Coil ID must be unique and less than 50 characters"
.ShowInput = True
.ShowError = True
End With
End Sub
' Create Comparison Functionality Button
Sub CreateComparisonButton(compWs As Worksheet)
Dim btnCompare As Shape
' Remove existing button if it exists
On Error Resume Next
compWs.Shapes("CompareCoilsButton").Delete
On Error GoTo 0
' Add new comparison button
Set btnCompare = compWs.Shapes.AddControl(xlControlButton, _
Left:=100, Top:=50, Width:=150, Height:=30)
With btnCompare
.Name = "CompareCoilsButton"
.OLEFormat.Object.Caption = "Compare Coils"
.OnAction = "CompareCoils"
End With
End Sub
' Macro to Compare Coils
Sub CompareCoils()
Dim wsTracking As Worksheet
Dim wsComparison As Worksheet
Dim lastRow As Long
Dim i As Long, j As Long, compRow As Long
' Set worksheets
Set wsTracking = ThisWorkbook.Sheets("Coil Tracking")
Set wsComparison = ThisWorkbook.Sheets("Coil Comparison")
' Clear previous comparisons
wsComparison.Range("A2:E1000").Clear
' Find last row with data in tracking sheet
lastRow = wsTracking.Cells(Rows.Count, 1).End(xlUp).Row
' Reset comparison row
compRow = 2
' Compare coils for various attributes
For i = 2 To lastRow
For j = i + 1 To lastRow
' Compare Weight
If wsTracking.Cells(i, 7).Value <> wsTracking.Cells(j, 7).Value Then
wsComparison.Cells(compRow, 1).Value = "Weight"
wsComparison.Cells(compRow, 2).Value = wsTracking.Cells(i, 1).Value
wsComparison.Cells(compRow, 3).Value = wsTracking.Cells(j, 1).Value
wsComparison.Cells(compRow, 4).Value = Abs(wsTracking.Cells(i,
7).Value - wsTracking.Cells(j, 7).Value)
wsComparison.Cells(compRow, 5).Value = "Difference Found"
compRow = compRow + 1
End If
' Compare Width
If wsTracking.Cells(i, 5).Value <> wsTracking.Cells(j, 5).Value Then
wsComparison.Cells(compRow, 1).Value = "Width"
wsComparison.Cells(compRow, 2).Value = wsTracking.Cells(i, 1).Value
wsComparison.Cells(compRow, 3).Value = wsTracking.Cells(j, 1).Value
wsComparison.Cells(compRow, 4).Value = Abs(wsTracking.Cells(i,
5).Value - wsTracking.Cells(j, 5).Value)
wsComparison.Cells(compRow, 5).Value = "Difference Found"
compRow = compRow + 1
End If
Next j
Next i
' Auto-fit columns
wsComparison.Columns("A:E").AutoFit
' Highlight differences
With wsComparison.Range("A2:E" & compRow - 1)
.Interior.Color = RGB(255, 220, 220)
.Font.Color = vbRed
End With
MsgBox "Coil Comparison Complete!", vbInformation
End Sub
' Initialize Workbook
Private Sub Workbook_Open()
Call SetupCoilTracking
End Sub
