Sub TransposeData()
Dim Rng As Range, r As Range, ka, Plate, k(), i As Long, c As Long, n As Long
Set Rng = Sheets("Sheet1").UsedRange.Resize(, 13).SpecialCells(2)
ReDim k(1 To Rng.Cells.Count, 1 To 4)
For Each r In Rng.Areas
ka = r
Plate = Trim$(Replace(ka(1, 1), "plate", "", , , vbTextCompare))
For i = 2 To UBound(ka, 1)
For c = 2 To UBound(ka, 2)
If Len(ka(i, c)) Then
n = n + 1
k(n, 1) = n: k(n, 2) = Plate
k(n, 3) = ka(i, 1) & ka(1, c)
k(n, 4) = ka(i, c)
End If
Next
Next
Next
With Sheets("Sheet2")
.Range("a1:d1").Value = Array("Count", "Plate", "Position", "Data")
.Range("a2").Resize(n, 4).Value = k
End With
End Sub
|