When in doubt, always post an attachment. Speeds up the communication considerably.
This copies it over as your output, and sorts.
Sub Trans()
Application.ScreenUpdating = False
Dim wsIn As Worksheet: Set wsIn = Sheets("input")
Dim wsOut As Worksheet: Set wsOut = Sheets("output")
Dim lastRow As Long
For Each rngCell In wsIn.Range("D2", wsIn.Range("J" & Rows.Count).End(xlUp))
lastRow = wsOut.Range("A" & Rows.Count).End(xlUp).Offset(1).Row
wsOut.Range("A" & lastRow) = wsIn.Cells(1, rngCell.Column)
wsOut.Range("B" & lastRow) = wsIn.Cells(rngCell.Row, 1)
wsOut.Range("C" & lastRow) = wsIn.Cells(rngCell.Row, 2)
wsOut.Range("D" & lastRow) = rngCell
Next
ActiveWorkbook.Worksheets("output").Sort.SortFields.Add Key:=Range("A1"), _
SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
With ActiveWorkbook.Worksheets("output").Sort
.SetRange Range("A2", Range("D" & Rows.Count).End(xlUp))
.Header = xlNo
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
Application.ScreenUpdating = True
End Sub
Bookmarks