Transpose certain cells in a row while keeping other cells intact

D

dyoung66

Hello,
I was hoping someone could help me with a problem I've been stuck on
for a while.

I have a file like so:

ID1 lName1 fName1 subj1 subj2 subj3
ID2 lName2 fName2 subj1 subj2 subj3
ID3 lName3 fName3 subj1 subj2 subj3
(etc)

that I need to convert to:

ID1 lName1 fName1 subj1
ID1 lName1 fName1 subj2
ID1 lName1 fName1 subj3
ID2 lName2 fName2 subj1
ID2 lName2 fName2 subj2
ID2 lName2 fName2 subj3
ID3 lName3 fName3 subj1
ID3 lName3 fName3 subj2
ID3 lName3 fName3 subj3

I can transpose easily enough, but I cant keep the first 3 fields
intact and repeat them for every row. (There are over 1000 rows in the
file)

Does anyone have any suggestions?

Thanks,
Damien.
 
G

Guest

Sub dyound()
n = Cells(Rows.Count, 1).End(xlUp).Row
k = n + 1

For i = 1 To n
v1 = Cells(i, 1).Value
v2 = Cells(i, 2).Value
v3 = Cells(i, 3).Value
For j = 1 To 3
Cells(k, 1).Value = v1
Cells(k, 2).Value = v2
Cells(k, 3).Value = v3
Cells(k, 4).Value = Cells(i, j + 3).Value
k = k + 1
Next
Next
End Sub
 
D

Dave Peterson

How about a macro:

Option Explicit
Sub testme01()

Dim iRow As Long
Dim FirstRow As Long
Dim LastRow As Long
Dim iCol As Long
Dim FirstCol As Long
Dim LastCol As Long
Dim HowManyToInsert As Long
Dim wks As Worksheet

Set wks = Worksheets("sheet1")

With wks
FirstCol = 4 'keep the first 3 static
FirstRow = 1
LastRow = .Cells(.Rows.Count, "A").End(xlUp).Row

For iRow = LastRow To FirstRow Step -1
LastCol = .Cells(iRow, .Columns.Count).End(xlToLeft).Column
HowManyToInsert = LastCol - FirstCol
If HowManyToInsert > 0 Then
.Rows(iRow + 1).Resize(HowManyToInsert).Insert
.Cells(iRow + 1, "A") _
.Resize(HowManyToInsert, FirstCol - 1).Value _
= .Cells(iRow, "A").Resize(1, FirstCol - 1).Value
.Cells(iRow + 1, FirstCol).Resize(HowManyToInsert, 1).Value _
= Application.Transpose(.Cells(iRow, FirstCol + 1) _
.Resize(1, HowManyToInsert))
End If
Next iRow

.Range(.Cells(1, FirstCol + 1), .Cells(1, .Columns.Count)) _
.EntireColumn.ClearContents
End With

End Sub

If you're new to macros, you may want to read David McRitchie's intro at:
http://www.mvps.org/dmcritchie/excel/getstarted.htm
 
T

Tom Ogilvy

Sub ExpandData()
Dim rng As Range, cell As Range
Dim rw As Long, i As Long

Set rng = Range(Cells(1, 1), Cells(Rows.Count, 1).End(xlUp))
Worksheets.Add After:=Worksheets(Worksheets.Count)
rw = 1
For Each cell In rng
For i = 4 To 6
Cells(rw, 1).Resize(1, 3).Value = _
cell.Resize(1, 3).Value
Cells(rw, 4).Value = cell.Offset(0, i - 1).Value
rw = rw + 1
Next i
Next cell
End Sub

worked on your sample data. If that is how your data is actually
structured, it should work.
 
Top