Need to shift excel cell values using VBA

Question

I have an excel sheet, where the data gets populated by SQL. As part of post processing, I need to format the spreadsheet as below.

Raw data:

**Emp ID** **Last Name** **First Name** **Department** **Title** **Office**
  1234     Stewart         John           Finance        Analyst   Office1
  5678     Malone          Rick           Marketing      Analyst   Office 2
  3456     Wresely         Eric           HR             Recuriter Office 3

Formatted Data

**Emp ID** **Last Name** **First Name**
  1234     Stewart         John
           **Department**  **Title** **Office**
           Finance         Analyst   Office1
**Emp ID** **Last Name** **First Name**
  5678     Malone          Rick      
           **Department**  **Title** **Office**
           Marketing      Analyst   Office 2
**Emp ID** **Last Name** **First Name**
  3456     Wresely         Eric      
           **Department**  **Title** **Office** 
           HR              Recuriter  Office 3    

Any help on how to accomplish this through VBA would be great

Answer 1

Alternative approach using arrays (note that this is not even the best possible approach, just an alternative one -- corrections and suggestions are more than welcome):

Sub BulletHell()

    Start = Timer()

    Dim WS0 As Worksheet, WS1 As Worksheet
    Dim EmpDetailsOne As Variant, EmpDetailsTwo As Variant
    Dim HeadOne() As Variant, HeadTwo() As Variant
    Dim RngTarget As Range, NumOfEmp As Long, aIter As Long

    With ThisWorkbook
        Set WS0 = .Sheets("Sheet1") 'Modify as necessary.
        Set WS1 = .Sheets("Sheet2") 'Modify as necessary.
    End With

    EmpDetailsOne = WS0.Range("A2:C101").Value 'Modify as necessary.
    EmpDetailsTwo = WS0.Range("D2:F101").Value 'Modify as necessary.

    HeadOne = Array("EmpID", "LastName", "FirstName")
    HeadTwo = Array("", "Department", "Title", "Office")
    Set RngTarget = WS1.Range("A1")
    NumOfEmp = UBound(EmpDetailsOne)

    For aIter = 1 To NumOfEmp
        With RngTarget
            .Resize(1, 3).Value = HeadOne
            .Offset(1, 0).Resize(1, 3).Value = Array(EmpDetailsOne(aIter, 1), EmpDetailsOne(aIter, 2), EmpDetailsOne(aIter, 3))
            .Offset(2, 0).Resize(1, 4).Value = HeadTwo
            .Offset(3, 1).Resize(1, 3).Value = Array(EmpDetailsTwo(aIter, 1), EmpDetailsTwo(aIter, 2), EmpDetailsTwo(aIter, 3))
        End With
        Set RngTarget = RngTarget.Offset(4, 0)
    Next aIter

    Debug.Print Timer() - Start

End Sub

Without any time-saving "tricks", this can process 200,000 records in ~20 seconds.

Answer 2

You can loop through the data, copy the values and write them to a new sheet

Sub CopyValues()

   Sheets(1).Activate
   For curRow = 2 To 20
         EmpId = Cells(curRow, 1).Value
         lastName = Cells(curRow, 2).Value
         firstName = Cells(curRow, 3).Value
         department = Cells(curRow, 4).Value
         Title = Cells(curRow, 5).Value

          ' write them to sheet 2
         Sheets(2).Cells(4 * curRow, 1).Value = "**Emp ID**  "
         Sheets(2).Cells(4 * curRow, 2).Value = "**First Name**"
         Sheets(2).Cells(4 * curRow, 3).Value = "**Last Name**"

         Sheets(2).Cells(4 * curRow + 1, 1).Value = EmpId
         Sheets(2).Cells(4 * curRow + 1, 2).Value = firstName
         Sheets(2).Cells(4 * curRow + 1, 3).Value = lastName

         Sheets(2).Cells(4 * curRow + 2, 2).Value = "**Department**"
         Sheets(2).Cells(4 * curRow + 3, 2).Value = department

         Sheets(2).Cells(4 * curRow + 2, 3).Value = "**Title**"
         Sheets(2).Cells(4 * curRow + 3, 3).Value = Title
   Next
   Sheets(2).Activate
End Sub

You should be able to adapt the rest as you need by trying it out and playing around with it.

This is the result of the code from above.