Excel VB to change the value of a cell dependent upon the value of another

Sub TransformData()
Dim ws As Worksheet
Dim lr As Long, i As Long, n As Long, j As Long, sr As Long
Dim cell As Range
Dim x()
Application.ScreenUpdating = False
Set ws = Sheets("Personnel_Records")
lr = ws.Cells(Rows.Count, 1).End(xlUp).Row
On Error Resume Next
For Each cell In ws.Range("E:E").SpecialCells(xlCellTypeBlanks).Areas
   If cell.Rows.Count > n Then n = cell.Rows.Count
Next cell
On Error GoTo 0
If n = 0 Then Exit Sub
ReDim x(1 To 1, 1 To n * 2)
For i = 2 To lr
   If sr = 0 Then sr = i
   If ws.Cells(i, 5) = "" Then
      j = j + 1
      x(1, j) = ws.Cells(i, 6)
      j = j + 1
      x(1, j) = ws.Cells(i, 7).Value
   ElseIf j > 0 Then
      ws.Cells(sr, 9).Resize(1, UBound(x, 2)).Value = x
      j = 0
      sr = i
      Erase x
      ReDim x(1 To 1, 1 To n * 2)
   Else
      j = 0
      sr = i
      Erase x
      ReDim x(1 To 1, 1 To n * 2)
   End If
Next i
ws.Columns.AutoFit
ws.Range("E:E").SpecialCells(xlCellTypeBlanks).EntireRow.Delete
ws.Range("A1").CurrentRegion.Borders.Color = vbBlack
Application.ScreenUpdating = True
MsgBox "Task Completed.", vbInformation
End Sub

Select all Open in new window