OK, try this. Copy and paste into a standard module.
Option Explicit
Sub sTranscribeData()
Dim rInterest As Range
Dim cell As Range
Dim lNR As Long, lLC As Long, i As Long
Application.ScreenUpdating = False
' determine the rows to process ... non blank constants
Set rInterest = Sheets("Data Entry").Range("A:A").SpecialCells(xlCellTypeConstants)
' clear the target area
With Sheets("After")
.Range("A1:D1").EntireColumn.Clear
End With
For Each cell In rInterest
' check if we've processed all the data
If cell.Offset(, 1) = "" Then GoTo lFormat
'Debug.Print cell.Value
With Sheets("After")
' determine the next row to place the data
lNR = .Range("A" & .Rows.Count).End(xlUp).Row + 1
'set up matrix header
If cell.Value = "S/N" Then
.Range("A" & lNR).Resize(, 4) = Array("Material Number", "Batch Number", "Defect Type", "Qty")
End If
' process each data row
If IsNumeric(cell.Value) Then
' determine how many columns to process
lLC = Sheets("Data Entry").Cells(cell.Row, 20).End(xlToLeft).Column
' process each column from column E
For i = 5 To lLC
.Cells(lNR, 1).Value = cell.Offset(0, 1).Value
.Cells(lNR, 2).Value = cell.Offset(0, 2).Value
.Cells(lNR, 3).Value = cell.Offset(-1, i - 1).Value
.Cells(lNR, 4).Value = cell.Offset(0, i - 1).Value
lNR = lNR + 1
Next 'i
End If
End With ' Sheets("After")
Next 'cell
lFormat:
' Format the output table
With Sheets("After").Range("A2").CurrentRegion
With .Borders
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With '.Borders
.HorizontalAlignment = xlCenter
End With 'Sheets("After").Range("A2").CurrentRegion
Application.ScreenUpdating = True
End Sub
Bookmarks