Sub IntermediateProcess()
Dim ws As Worksheet, newWs As Worksheet
Dim lastRow As Long, newRow As Long, seqNum As Integer, subSeqNum As Integer
Dim cell As Range, startRow As Long
Dim foundItem As Boolean
Dim cb As CheckBox
Dim prefix As String, suffix As String, codeFormat As String
Dim currentMainCode As String
Dim subChar As String
' Ask user for code format: Prefix & Suffix
prefix = InputBox("Enter the prefix for the code format (e.g., '02-'):", "Code
Format Selection", "02-")
If prefix = "" Then
MsgBox "Prefix cannot be empty!", vbExclamation, "Error"
Exit Sub
End If
suffix = InputBox("Enter the suffix for the code format (e.g., 'T'):", "Code
Format Selection", "T")
If suffix = "" Then
MsgBox "Suffix cannot be empty!", vbExclamation, "Error"
Exit Sub
End If
' Set the active worksheet
Set ws = ActiveSheet
' Find the last row in column A
lastRow = ws.Cells(ws.Rows.Count, 1).End(xlUp).Row
foundItem = False ' Flag to track when "Item" is found
' Search for "Item" in column A
For Each cell In ws.Range("A1:A" & lastRow)
If InStr(1, cell.Value, "Item", vbTextCompare) > 0 Then
foundItem = True
startRow = cell.Row + 2 ' Skip one row after "Item"
Exit For
End If
Next cell
' If "Item" is not found, exit
If Not foundItem Then
MsgBox "'Item' not found in column A!", vbExclamation, "Error"
Exit Sub
End If
' Create a new worksheet for output
Set newWs = ThisWorkbook.Sheets.Add
newWs.Name = "Filtered Data"
' Set headers
newWs.Cells(1, 1).Value = "SHEETS"
newWs.Cells(1, 2).Value = "CODE"
newWs.Cells(1, 3).Value = "TITLE"
newWs.Cells(1, 4).Value = "WORK DESCRIPTION"
newWs.Cells(1, 5).Value = "RATE.(RS)"
newWs.Cells(1, 6).Value = "QTY"
newWs.Cells(1, 7).Value = "UNIT OF RATE"
newWs.Cells(1, 8).Value = "CARTAGE"
newWs.Cells(1, 9).Value = "TESTING & COMMISSION"
newWs.Cells(1, 10).Value = "SKILLED DAYS"
newWs.Cells(1, 11).Value = "UNSKILLED DAYS"
newWs.Cells(1, 12).Value = "QUOTATION DATE"
newWs.Cells(1, 13).Value = "SUPPLIER"
' Format header row
With newWs.Range("A1:M1")
.Font.Bold = True
.Interior.Color = RGB(200, 200, 200)
End With
newRow = 2 ' Start filling from second row
seqNum = 1 ' Initialize main sequence number
subSeqNum = 0 ' Initialize subsection sequence number
currentMainCode = "" ' Track main section codes
' Loop through column A starting after "Item"
For Each cell In ws.Range("A" & startRow & ":A" & lastRow)
If Trim(cell.Value) <> "" Then ' Ensure the cell is not empty
' Check if checkbox in the last column (e.g., column N) is checked
For Each cb In ws.CheckBoxes
If cb.TopLeftCell.Row = cell.Row Then
If cb.Value = 1 Then ' Checkbox is checked
' Determine if it's a main section (starts with a number)
or a subsection (starts with a letter)
If IsNumeric(Left(cell.Value, 1)) Then
' This is a main section (starting with a number)
currentMainCode = prefix & seqNum & suffix
subSeqNum = 0 ' Reset subsection counter
seqNum = seqNum + 1 ' Increment main sequence
Else
' This is a subsection (starting with a letter)
subSeqNum = subSeqNum + 1
subChar = Chr(96 + subSeqNum) ' Convert 1 ? a, 2 ? b, 3
? c, etc.
currentMainCode = prefix & (seqNum - 1) & suffix & "("
& subChar & ")"
End If
' Assign the structured code
newWs.Cells(newRow, 2).Value = currentMainCode
' Copy other values to the new sheet
newWs.Cells(newRow, 1).Value = cell.Offset(0, 8).Value '
SHEETS from column I
newWs.Cells(newRow, 3).Value = cell.Offset(0, 9).Value '
TITLE from column J
newWs.Cells(newRow, 4).Value = cell.Offset(0, 1).Value '
DESCRIPTION from column B
newWs.Cells(newRow, 5).Value = cell.Offset(0, 5).Value '
RATE from column F
newWs.Cells(newRow, 6).Value = cell.Offset(0, 4).Value '
QTY from column E
newWs.Cells(newRow, 7).Value = cell.Offset(0, 3).Value '
UNIT from column D
newWs.Cells(newRow, 8).Value = cell.Offset(0, 10).Value '
CARTAGE from column K
newWs.Cells(newRow, 9).Value = cell.Offset(0, 11).Value '
TESTING from column L
newWs.Cells(newRow, 10).Value = cell.Offset(0, 12).Value '
SKILLED from column M
newWs.Cells(newRow, 11).Value = cell.Offset(0, 13).Value '
UNSKILLED from column N
newWs.Cells(newRow, 12).Value = cell.Offset(0, 14).Value '
QUOTATION from column O
newWs.Cells(newRow, 13).Value = cell.Offset(0, 15).Value '
SUPPLIER from column p
newRow = newRow + 1 ' Move to the next row
End If
End If
Next cb
End If
Next cell
' Adjust column widths for better visibility
newWs.Columns("A").ColumnWidth = 15 ' SHEETS
newWs.Columns("B").ColumnWidth = 15 ' CODE
newWs.Columns("C").ColumnWidth = 15 ' TITLE
newWs.Columns("D").ColumnWidth = 50 ' WORK DESCRIPTION
newWs.Columns("E").ColumnWidth = 15 ' RATE
newWs.Columns("F").ColumnWidth = 15 ' QTY
newWs.Columns("G").ColumnWidth = 15 ' UNIT OF RATE
newWs.Columns("H").ColumnWidth = 15 ' CARTAGE
newWs.Columns("I").ColumnWidth = 15 ' TESTING & COMMISSION
newWs.Columns("J").ColumnWidth = 15 ' SKILLED DAYS
newWs.Columns("K").ColumnWidth = 15 ' UNSKILLED DAYS
newWs.Columns("L").ColumnWidth = 15 ' QUOTATION DATE
newWs.Columns("M").ColumnWidth = 15 ' SUPPLIER
' Enable text wrapping for long text
newWs.Columns.WrapText = True ' Enable wrap for WORK DESCRIPTION
newWs.Columns("D").Font.Size = 10 ' Set font size to 10 for WORK DESCRIPTION
' Find the last row with data
Dim lastDataRow As Long
lastDataRow = newWs.Cells(newWs.Rows.Count, 2).End(xlUp).Row
' Adjust row heights for readability
newWs.Rows("1").RowHeight = 30
newWs.Range("A2:M" & lastDataRow).Rows.AutoFit ' Apply row height only to rows
with data
MsgBox "Data extraction complete!", vbInformation, "Success"
End Sub
