Turn horizontal data to vertical

Panoos64 · Jan 17, 2018

Hi all, I would like to prepare a VBA code so that to run through row “2” and where find blank column, should turn the section’s data below of the previous one with one blank row. Simply I would like to turn the horizontal data to vertical style but should place employee’s code and name in adjacent “X” cells. In F.1. are the original data and in F.2. is the expected result. Many thanks in advance

F.1.

	A	B	C	C	D	E	F	G	H	I	J
1		1048	1048	1048	1048		1255	1255	1255	1255	1444
2		EMP.1048	EMP.1048	EMP.1048	EMP.1048		EMP.1255	EMP.1255	EMP.1255	EMP.1255	EMP.1255
3		X	X	X	X		X	X	X	X	X

F.2.

	A	B	C	D	E	F
1	1048	EMP.1048	X	X	X	X
2
3	1255	EMP.1255	X	X	X	X

hatstand · Jan 17, 2018

Hi ,

Is this the type of thing you are after. It takes anything in rows 1:3, Transposes them, then removes the duplicates. I haven't completed it yet as the 'x's do not poulate yet. I set out the sheet as per your example.

Sub MoveIt()

Dim r As Long, i As Long

Rows("1:3").Copy
Range("A5").PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:=False, Transpose:=True

r = Cells(1000, 1).End(xlUp).Row
Range(Cells(6, 1), Cells(r, 3)).Select
ActiveSheet.Range("$A$6:$C$" & r).RemoveDuplicates Columns:=Array(1, 2, 3), Header:=xlNo

Range("A6").Select

End Sub

Panoos64 · Jan 17, 2018

Hi hats, thanks you so much for your support and your time you spend for me so that to resolve my issue. I will test it whenever you complete the code and i will inform you accordingly.

hatstand · Jan 17, 2018

Hi,

I have adeed a few lines to add your 'x's. Hopefully it will be what you are after.

Sub MoveIt()
Application.ScreenUpdating = False
Dim r As Long, i As Long

Rows("1:3").Copy
Range("A5").PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:=False, Transpose:=True

r = Cells(1000, 1).End(xlUp).Row
Range(Cells(6, 1), Cells(r, 3)).Select
ActiveSheet.Range("$A$6:$C$" & r).RemoveDuplicates Columns:=Array(1, 2, 3), Header:=xlNo
Cells(1, 6).Select

For i = 6 To Cells(1000, 1).End(xlUp).Row
If Cells(i, 1) <> "" Then
Range(Cells(i, 3), Cells(i, 3 + Application.WorksheetFunction.CountIf(Range("A1:K1"), Cells(i, 1)) - 1)).Value = "x"
End If
Next
Application.ScreenUpdating = True
End Sub

Panoos64 · Jan 18, 2018

Hi hats, The code works perfect and nicely. I am glad that you help to create the above and many thanks for your support and your time spent for my issue. Have a great day!

Panoos64 · Jan 18, 2018

Apologies that i bother you again hats. Is it possible to amend a little pit the code so that to valid any other symbols? Note that the table is employees time schedule and the "X" it means that he/she worked full day. in addition i have HD symbols which it means that he/she worked half day or blank which it means that he/she has a day off. The code should valid any symbols which are in the table. I would be greatly appreciate if you could help me to develop the code. Many thanks in advance. Have a great lovely day!

hatstand · Jan 19, 2018

Hi,

I have changed the code to copy the values in row 3 to the corresponding value in column A. I'm sure there are better ways to do this, but it works so hopefully will do what you need.

Code:

Sub MoveIt()
Application.ScreenUpdating = False
Dim r As Long, i As Long
   Dim ColNum As Range

    Rows("1:2").Copy
        Range("A5").PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:=False, Transpose:=True
    
    r = Cells(1000, 1).End(xlUp).Row
        Range(Cells(6, 1), Cells(r, 3)).Select
            ActiveSheet.Range("$A$6:$C$" & r).RemoveDuplicates Columns:=Array(1, 2, 3), Header:=xlNo
            Cells(6, 1).Select
    
    For i = 6 To Cells(1000, 1).End(xlUp).Row
        If Cells(i, 1) <> "" Then
        t = Application.WorksheetFunction.CountIf(Range("1:1"), Cells(i, 1).Value)
        Set ColNum = Range("1:1").Find(Cells(i, 1).Value)
            Range(Cells(i, 3), Cells(i, 3 + t)).Value = Range(Cells(3, ColNum.Column), Cells(3, ColNum.Column + t)).Value
        End If
    Next
Application.ScreenUpdating = True
End Sub

Fluff · Jan 19, 2018

Another option is

Code:

Sub CopyTrans()

   Dim Rng As Range

   For Each Rng In Sheets("Test1").Rows(1).SpecialCells(xlConstants).Areas
      With Sheets("Test2").Range("A" & Rows.Count).End(xlUp).Offset(1)
         .Value = Rng(1).Value
         .Offset(, 1).Value = Rng.Offset(1).Resize(1).Value
         .Offset(, 2).Resize(, Rng.Count).Value = Rng.Offset(2).Value
      End With
   Next Rng
End Sub

@hatstand
When posting code could you please use code tags (the # icon in the reply window) Cheers

hatstand · Jan 19, 2018

Hi Fluff,

No problem, using code tags, unfortunetly I'm unsure what they are?

Fluff · Jan 19, 2018

In the message/reply window there is a # icon.
Either paste your code into the reply window, select it & then click the #icon
or click the # icon & then paste your code between the 2 tags that appear

Turn horizontal data to vertical

Panoos64

Well-known Member

Excel Facts

hatstand

Well-known Member

Panoos64

Well-known Member

hatstand

Well-known Member

Panoos64

Well-known Member

Panoos64

Well-known Member

hatstand

Well-known Member

Fluff

MrExcel MVP, Moderator

hatstand

Well-known Member

Fluff

MrExcel MVP, Moderator

Similar threads

Forum statistics

Share this page

Turn horizontal data to vertical

Well-known Member

Excel Facts

Well-known Member

Well-known Member

Well-known Member

Well-known Member

Well-known Member

Well-known Member

MrExcel MVP, Moderator

Well-known Member

MrExcel MVP, Moderator

Similar threads

Forum statistics

Share this page

We've detected that you are using an adblocker.

Which adblocker are you using?

Disable AdBlock

Disable AdBlock Plus

Disable uBlock Origin

Disable uBlock