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

Meaning merely that department / title and office should be on the next line ? — Trace
– Trace, Commented Feb 25, 2014 at 14:29
Yes, for each emp id, need to move the department, titile and office to row, and need to keep the headings — user3324344
– user3324344, Commented Feb 25, 2014 at 14:42
Thanks. Right now I have small data set to test against and it is working fine. — user3324344
– user3324344, Commented Feb 25, 2014 at 15:39

surfmuggle · Accepted Answer · 2014-02-25 15:06:21Z

1

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.

Output of code above

edited Feb 25, 2014 at 15:06

answered Feb 25, 2014 at 14:31

surfmuggle

6,0468 gold badges59 silver badges97 bronze badges

Sign up to request clarification or add additional context in comments.

4 Comments

Trace Over a year ago

Depending on the amount of data, this code could run very slowly.

surfmuggle Over a year ago

You can switch screen updating off and if that is not enough work with ranges. But i have copied hundreds of rows this way and have not hit a problem. If you do not mind that the macro takes a few minutes. Do you have any alternatives next to the ones i mentioned?

Trace Over a year ago

I'm not saying it's wrong. Generally, the recommended way to get optimum performance is to load data into memory (eg. from a recordset to an array), resize the array to the dimensions of the range, and render the array with a single write action oRange = vArray. Currently you will perform a write action on every single item. For a limited number of records, I suppose it won't hurt.

WGS Over a year ago

+1: In this regard, @KimGysen is correct. Up to about ten thousand records, this will take a few seconds. Once it hits 100,000 or 200,000 records, though, the difference between this and an array approach will clearly show. However, as OP stated that the dataset is small, all is fine. :)

WGS · Accepted Answer · 2014-02-25 17:13:31Z

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.

Collectives™ on Stack Overflow

Need to shift excel cell values using VBA

2 Answers 2

4 Comments

Comments

Your Answer

Hot Network Questions

Collectives™ on Stack Overflow

2 Answers 2

4 Comments

Comments

Your Answer

Sign up or log in

Post as a guest

Related