Horizontal rows into multiple colums

Dustic

New member
Joined
Jul 10, 2018
Messages
2
Reaction score
0
Points
0
Excel Version(s)
2016
I have several rows that each row has data related to an individual location with details about it and 5 items that will be unique for each of the locations.

What I'm needing is a formula or a macro that will take the location and its details and then the 1st items and put them in a single row then repeat one row down the same location information but skip item 1 and return item 2. Repeating this process until there are no more items for location A and then move to location B and item 1.

This is for a document that I will send out to have it filled in by others & I will receive back some with over 100 rows of locations and others that have less than 10, I'll need to make sure the formula works regardless of the number of rows.
 
As a starter, in the attached is a button (near cell C7) which when clicked calls the macro blah.
See comments/queries in the code.
The new table starts at cell A31.
If satisfactory I'll add code to create a new workbook.
Code:
Sub blah()
Set Destn = Range("A31")

Range("Z3:AK4").Select    'delete this line, but manually select the equivalent range before running this macro.
ActiveWindow.ScrollColumn = 26: ActiveWindow.ScrollRow = 1    'delete this line later.
MsgBox "note what needs to be selected before this macro is called"    'delete this line later.

Set myrng = Selection
For Each rw In myrng.Rows
  ThisRow = rw.Row
  For colm = 1 To myrng.Columns.Count Step 2
    If Len(rw.Cells(colm).Value) > 0 Then
      With Destn
        .Value = Cells(ThisRow, "D").Value
        .Offset(, 1).Value = Cells(ThisRow, "B").Value
        .Offset(, 2).Value = rw.Cells(colm).Value
        '.Offset(, 3).Value = Cells(ThisRow, "").Value'don't know where column D info comes from.
        .Offset(, 5).Value = Cells(ThisRow, "E").Value
        .Offset(, 6).Value = Cells(ThisRow, "C").Value    ' don't know where the additional ',VAL,XTERM' data comes from.
        .Offset(, 7).Value = rw.Cells(colm + 1).Value
      End With
      Set Destn = Destn.Offset(1)
    End If
  Next colm
Next rw
Destn.Select
End Sub
 

Attachments

  • ExcelGuru9171Book1.xlsm
    20.9 KB · Views: 5
Back
Top