Sub b1194878b()
'https://www.excelforum.com/excel-programming-vba-macros/1194878-re-arranging-cell-values.html
Dim i As Long, j As Long, k As Long, m As Long
Dim strT As String, strG As String
Dim va, vc
If ActiveSheet.Name <> "Output" Then Sheets("Output").Activate
rr = Range("A:A").Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
va = Range("A1:I" & rr)
ReDim vc(1 To UBound(va, 1) * 4, 1 To 4)
For i = 3 To UBound(va, 1)
If InStr(va(i, 3), "Weight") Then
strT = Replace(va(i - 2, 1), vbLf, "")
For m = 1 To 7 Step 2
strG = Replace(va(i, m + 1), vbLf, "")
For j = i + 2 To i + 8
If va(j, m + 1) <> "" Then
k = k + 1
vc(k, 1) = va(j, m + 1)
vc(k, 2) = va(j, m + 2)
vc(k, 3) = strG
vc(k, 4) = strT
End If
Next
Next
i = i + 8
End If
If InStr(va(i, 6), "Competencies") Then
k = k + 1
vc(k, 1) = "Competencies"
vc(k, 2) = va(i, 7)
vc(k, 3) = "Competencies"
vc(k, 4) = strT
End If
If InStr(va(i, 6), "Leadership") Then
k = k + 1
vc(k, 1) = "Leadership"
vc(k, 2) = va(i, 7)
vc(k, 3) = "Leadership"
vc(k, 4) = strT
End If
Next
With Sheets("Result")
.Range("A3").Resize(k, 4) = vc
'.Columns("A:D").AutoFit
'.Range("B3").Resize(k, 1).NumberFormat = "0%"
End With
End Sub
Bookmarks