A hard one...rearanging data

[gentrric]

I'm tring to rearange data for import into Access. All related data is in the same row and I need to transpose some of the cells within this row into columns. There are over 1000 rows. Is there a simple way to do this other than copy and paste?

Book1
	A	B	C	D	E	F	G	H	I	J
1	ThedatathatIneedtorearangelookslikethis.Thereareover1000rows.
2
3	Course#	Classname	Instructor	Participant	Participant	Participant	Participant	Participant	Participant
4	WQ3005	MSWord	Smith	Judy	Sam	Henry	Larry	Diane
5	WQ2145	MSAccess	Sam	Henry	Simon	Peter	Nancy
6	WQ3211	Dataentry	John	Peter	Patti
7
8	Ineedtotransposetheparticipantsineachclassfromrowstocolumns,butleaveeverythingelseinrowslikethis.
9
10	Course#	Classname	Instructor	Participant
11	WQ3005	MSWord	Smith	Judy
12				Sam
13				Henry
14				Larry
15				Diane
16	WQ2145	MSAccess	Sam	Henry
17				Simon
18				Peter
19				Nancy
20	WQ3211	Dataentry	John	Peter
21				Patti
Sheet1

This message was edited by gentrric on 2002-09-25 19:35

 

[Andrew Poulsom]

Try this:

Sub Test()
    Dim ShSource As Worksheet
    Dim ShTarget As Worksheet
    Dim RowSource As Long
    Dim ColSource As Integer
    Dim RowTarget As Long
    Dim ColTarget As Integer
    Dim x As Integer
'   *** Change name of source sheet to suit ***
    Set ShSource = Sheets("Sheet1")
'   *** Change address of first cell in source range to suit ***
    RowSource = ShSource.Range("A1").Row
    ColSource = 4
    RowTarget = 1
'   Create target worksheet
    Set ShTarget = Worksheets.Add
'   Copy headings
    With ShTarget
        For x = 1 To ColSource
            Cells(RowTarget, x) = ShSource.Cells(RowSource, x)
        Next x
    End With
    RowSource = RowSource + 1
    RowTarget = RowTarget + 1
    ColTarget = 4
    Do
'       All done if nothing in Column A on source sheet
        If IsEmpty(ShSource.Cells(RowSource, 1)) Then Exit Do
        If IsEmpty(ShSource.Cells(RowSource, ColSource)) Then
'           Next record
            RowSource = RowSource + 1
            ColSource = 4
        Else
'           Next participant
            For x = 1 To 3
                ShTarget.Cells(RowTarget, x) = ShSource.Cells(RowSource, x)
            Next x
            ShTarget.Cells(RowTarget, ColTarget) = ShSource.Cells(RowSource, ColSource)
            RowTarget = RowTarget + 1
            ColSource = ColSource + 1
        End If
    Loop
End Sub

 

[gentrric]

[No message]

 

[gentrric]

Thanks for taking the time to supply me with this code. I'm only beginning my VB experience, but I think I know enough to understand a little of this code. It worked fine, but only for the first 4 columns. I was able to edit it some, but not the right way to make it work. If it makes a differance, the longest row has data in the 40th column. I have about 1100 rows. Some rows only have data in the first 3-4 columns. None of the rows have data in all 40 columns. How else can the code be edited to grab all of the data and keep it together?

 

[Andrew Poulsom]

As you have seen my code assumed a contiguous list of participants in each row. This will allow for blanks in the columns provided that all columns contain the heading:

Sub Test()
    Dim ShSource As Worksheet
    Dim ShTarget As Worksheet
    Dim RowSource As Long
    Dim LastCol As Integer
    Dim ColSource As Integer
    Dim RowTarget As Long
    Dim ColTarget As Integer
    Dim x As Integer
'   *** Change name of source sheet to suit ***
    Set ShSource = Sheets("Sheet1")
'   *** Change address of first cell in source range to suit ***
    RowSource = ShSource.Range("A1").Row
'   *** Change row number (headings) to suit ***
    LastCol = ShSource.Range("IV1").End(xlToLeft).Column
    ColSource = 4
    RowTarget = 1
'   Create target worksheet
    Set ShTarget = Worksheets.Add
'   Copy headings
    With ShTarget
        For x = 1 To ColSource
            Cells(RowTarget, x) = ShSource.Cells(RowSource, x)
        Next x
    End With
    RowSource = RowSource + 1
    RowTarget = RowTarget + 1
    ColTarget = 4
    Do
'       All done if nothing in Column A on source sheet
        If IsEmpty(ShSource.Cells(RowSource, 1)) Then Exit Do
        If IsEmpty(ShSource.Cells(RowSource, ColSource)) Then
'           No Participant
            ColSource = ColSource + 1
        Else
'           Next participant
            For x = 1 To 3
                ShTarget.Cells(RowTarget, x) = ShSource.Cells(RowSource, x)
            Next x
            ShTarget.Cells(RowTarget, ColTarget) = ShSource.Cells(RowSource, ColSource)
            RowTarget = RowTarget + 1
            ColSource = ColSource + 1
        End If
        If ColSource > LastCol Then
'           Next record
            RowSource = RowSource + 1
            ColSource = 4
        End If
     Loop
End Sub