Trying to move horizontal data into vertical data with other fields

[richard12]

I have lists of vacation times in a spreadsheet with multiple vacation columns that need to be placed, with other data, into a vertical data formatted spreadsheet. This now requires multiple cut/paste into another sheet, then upload to Microsoft Access to create relationships in a query that is copy/pasted into a spreadsheet to get the multiple rows of the same employee with different vacation dates. I would like to eliminate using Access, if possible, and use Excel to get to the sheet that can be used in a program. There is an employee sheet that has rows of employees with their personal data that is used to make a final Excel worksheet. The goal is to make a sheet with the same employee multiple times so vacation weeks can be accounted for and used in a query. See Sheet 2 example below. I am using Excel 2013

Sheet1 from managers
Grp Emp# LastNM FirstNM Vac Week Vac Week Vac Week Vac Week Vac Week Vac

02	503941	SMITH	JOHN	3/11/2018	6/17/2018	9/30/2018	11/4/2018
02	500007	JONES	ANDY	1/28/2018	2/4/2018	4/22/2018	7/1/2018	11/18/2018	11/25/2018
02	544899	ANDERSON	MAX	4/29/2018	5/6/2018	5/13/2018	12/30/2018
03	544671	MAUL	MIKE	3/25/2018	4/1/2018	7/8/2018
03	543445	JONES	SAM	5/6/2018	8/5/2018	8/12/2018	10/7/2018	11/11/2018

<colgroup><col><col><col><col><col><col span="5"></colgroup><tbody>
</tbody>

Sheet2 is using manager input and HR employee data from separate pages. I need to somehow have multiple rows of the same data to meet the number of columns of vacation week dates. The purpose is to have this data so the selection of an employee's vacation week might find similar employees, not on vacation, who could substitute for the employee on vacation. The order or format of Sheet 2 is not important if that matters.

EMPLOYEE#	LastNM	FirstNM	ZIP	EstZIP	VacWeek
503941	SMITH	JOHN	54126	54344	3/11/2018
503941	SMITH	JOHN	54126	54344	6/17/2018
503941	SMITH	JOHN	54126	54344	9/30/2018
503941	SMITH	JOHN	54126	54344	11/4/2018
500007	JONES	ANDY	52537	54443	1/28/2018
500007	JONES	ANDY	52537	54443	2/4/2018
500007	JONES	ANDY	52537	54443	4/22/2018
500007	JONES	ANDY	52537	54443	7/1/2018
500007	JONES	ANDY	52537	54443	11/18/2018
500007	JONES	ANDY	52537	54443	11/25/2018

<colgroup><col><col><col><col><col><col></colgroup><tbody>
</tbody>

 

[Joe4]

Where is ZIP and EstZip coming from?
If it is coming from another sheet, please let us know what sheet that is, and what the structure of that data looks like.

 

[Fluff]

How about

Sub copyTranspose()
   Dim Sws As Worksheet
   Dim Dws As Worksheet
   Dim Cl As Range
   Dim Qty As Long
   Dim Cols As Long
   
   Set Sws = Sheets("Sheet1")
   Set Dws = Sheets("Sheet2")
   Cols = Sws.Cells(1, Columns.Count).End(xlToLeft).Column - 4
   For Each Cl In Sws.Range("B2", Sws.Range("B" & Rows.Count).End(xlUp))
      Qty = Application.CountA(Cl.Offset(, 3).Resize(, Cols))
      With Dws.Range("A" & Rows.Count).End(xlUp).Offset(1)
         Cl.Resize(, 3).Copy .Resize(Qty)
         .Offset(, 5).Resize(Qty).Value = Application.Transpose(Cl.Offset(, 3).Resize(, Qty))
      End With
   Next Cl
   
End Sub

This will copy the data from sheet1 to sheet2. In order to do the ZIP & EstZIP, we'll need more info

 

[richard12]

Amazing how well your VB code worked. Thank you very much. That alone will save so many hours. I'm going to setup the HR employee record sheet in Excel.

How about

Sub copyTranspose()
   Dim Sws As Worksheet
   Dim Dws As Worksheet
   Dim Cl As Range
   Dim Qty As Long
   Dim Cols As Long
   
   Set Sws = Sheets("Sheet1")
   Set Dws = Sheets("Sheet2")
   Cols = Sws.Cells(1, Columns.Count).End(xlToLeft).Column - 4
   For Each Cl In Sws.Range("B2", Sws.Range("B" & Rows.Count).End(xlUp))
      Qty = Application.CountA(Cl.Offset(, 3).Resize(, Cols))
      With Dws.Range("A" & Rows.Count).End(xlUp).Offset(1)
         Cl.Resize(, 3).Copy .Resize(Qty)
         .Offset(, 5).Resize(Qty).Value = Application.Transpose(Cl.Offset(, 3).Resize(, Qty))
      End With
   Next Cl
   
End Sub

This will copy the data from sheet1 to sheet2. In order to do the ZIP & EstZIP, we'll need more info

 

[Fluff]

Glad we could help & thanks for the feedback

 

[richard12]

Joe4,Fluff,

This is the HR sheet example. It can be rearranged if necessary as it is just output from a database. To do a step, to use Google maps, I need the HR, other than duplicate, information added to each row of vacation date. Zip is the employee Zip, EstZIP is the workplace zip. The other fields are select or exclude fields to only get those employees who match criteria.

EMPLOYEE#

LastNM

FirstNM

ZIP

EstZIP

Circuit#

Series

Grade

Remarks

IM

RTE/SS

LIVESTOCK

POULTRY

PHV

THERMAL PROCESSING

EPI

NPIS

503941

SMITH

JOHN

56007

55912

31

0701

12

FALSE

TRUE

FALSE

FALSE

TRUE

FALSE

FALSE

FALSE

500007

JONES

ANDY

53563

53132

17

0701

12

FALSE

TRUE

FALSE

FALSE

TRUE

FALSE

FALSE

FALSE

544899

ANDERSON

MAX

50707

52204

29

0701

12

FALSE

TRUE

FALSE

FALSE

TRUE

FALSE

FALSE

FALSE

544671

MAUL

MIKE

56082

55336

12

0701

12

FALSE

TRUE

FALSE

FALSE

TRUE

TRUE

FALSE

FALSE

543445

JONES

SAM

57350

57399

35

0701

12

FALSE

TRUE

FALSE

FALSE

TRUE

FALSE

FALSE

FALSE

<colgroup><col><col><col><col><col><col><col span="2"><col><col><col><col><col><col><col><col><col></colgroup><tbody>
</tbody>

 

[Fluff]

How about

Sub copyTranspose()
   Dim Sws As Worksheet
   Dim Dws As Worksheet
   Dim Hrws As Worksheet
   Dim Fnd As Range
   Dim Cl As Range
   Dim Qty As Long
   Dim Cols As Long
   
   Set Sws = Sheets("Sheet1")
   Set Dws = Sheets("Sheet2")
   Set Hrws = Sheets("HR")
   
   Cols = Sws.Cells(1, Columns.Count).End(xlToLeft).Column - 4
   For Each Cl In Sws.Range("B2", Sws.Range("B" & Rows.Count).End(xlUp))
      Qty = Application.CountA(Cl.Offset(, 3).Resize(, Cols))
      With Dws.Range("A" & Rows.Count).End(xlUp).Offset(1)
         Set Fnd = Hrws.Range("A:A").Find(Cl.Value, , , xlWhole, , , , , False)
         Cl.Resize(, 3).Copy .Resize(Qty)
         .Offset(, 5).Resize(Qty).Value = Application.Transpose(Cl.Offset(, 3).Resize(, Qty))
         .Offset(, 3).Resize(Qty, 2).Value = Fnd.Offset(, 3).Resize(, 2).Value
      End With
   Next Cl
   
End Sub

 

[richard12]

Fluff - Thanks for the additional VBA, it worked perfectly to place the 2 Zip codes into Sheet 2 and I was able to change ".Offset" in the next to last line to have the date before the Zip codes. I tried to copy the last ".Offset" line and change various numbers to add the rest of the HR data elements to the Sheet 2 final product. That didn't work as I got numbers not in the HR data and N/A for most of my efforts. Is there a way to get all the data after the HR Sheet Zipcodes into Sheet 2 for every record?

At one time, I did see the series in Sheet 2, but that eventually disappeared. However, when the series went into Sheet 2, it dropped the leading "0" as if it was a number. I had all fields in the HR Sheet formatted as Text. I do have a code to add 0's back so it is trivial, just odd. But is there a way to account for this before the transfer?

Most of the time, VB added the VacationDate formats as a number. It is easy to reformat as a date but it seems odd it happens. Do you know if this is normal?

Thank you for the help you have given. I really appreciate knowing there are ways to move data in Excel. I thought VB was difficult in Access, but Excel concepts and coding are really challenging.

 

[Fluff]

Give this a go

Sub copyTranspose()
   Dim Sws As Worksheet
   Dim Dws As Worksheet
   Dim Hrws As Worksheet
   Dim Fnd As Range
   Dim Cl As Range
   Dim Qty As Long
   Dim Cols As Long
   
   Set Sws = Sheets("Sheet1")
   Set Dws = Sheets("Sheet2")
   Set Hrws = Sheets("HR")
   
   Cols = Sws.Cells(1, Columns.Count).End(xlToLeft).Column - 4
   For Each Cl In Sws.Range("B2", Sws.Range("B" & Rows.Count).End(xlUp))
      Qty = Application.CountA(Cl.Offset(, 3).Resize(, Cols))
      With Dws.Range("A" & Rows.Count).End(xlUp).Offset(1)
         Set Fnd = Hrws.Range("A:A").Find(Cl.Value, , , xlWhole, , , , , False)
         Cl.Resize(, 3).Copy .Resize(Qty)
         .Offset(, 3).Resize(Qty).Value = Application.Transpose(Cl.Offset(, 3).Resize(, Qty))
         Fnd.Offset(, 3).Resize(, 16).Copy .Offset(, 4).Resize(Qty, 16)
         .Offset(, 3).NumberFormat = "mm/dd/yyyy"
      End With
   Next Cl
   
End Sub

 

[richard12]

Thanks again for your help. The new code worked perfectly. I have been trying the process with the real data, 740 employees and 3471 leave requests with astonishing results. Although I had to add some error code because of errors in data, it only takes a few seconds to merge the two sheets. From hours to seconds is really great. The errors were caused by having employees on the Vacation sheet who had left and were not on the HR sheet. Having the errors show up worked out since the employee data columns had no data, so a quick sort, check, and delete resolved that problem.

Give this a go

Sub copyTranspose()
   Dim Sws As Worksheet
   Dim Dws As Worksheet
   Dim Hrws As Worksheet
   Dim Fnd As Range
   Dim Cl As Range
   Dim Qty As Long
   Dim Cols As Long
   
   Set Sws = Sheets("Sheet1")
   Set Dws = Sheets("Sheet2")
   Set Hrws = Sheets("HR")
   
   Cols = Sws.Cells(1, Columns.Count).End(xlToLeft).Column - 4
   For Each Cl In Sws.Range("B2", Sws.Range("B" & Rows.Count).End(xlUp))
      Qty = Application.CountA(Cl.Offset(, 3).Resize(, Cols))
      With Dws.Range("A" & Rows.Count).End(xlUp).Offset(1)
         Set Fnd = Hrws.Range("A:A").Find(Cl.Value, , , xlWhole, , , , , False)
         Cl.Resize(, 3).Copy .Resize(Qty)
         .Offset(, 3).Resize(Qty).Value = Application.Transpose(Cl.Offset(, 3).Resize(, Qty))
         Fnd.Offset(, 3).Resize(, 16).Copy .Offset(, 4).Resize(Qty, 16)
         .Offset(, 3).NumberFormat = "mm/dd/yyyy"
      End With
   Next Cl
   
End Sub