A hard one...rearanging data

gentrric

New Member
Joined
Sep 24, 2002
Messages
3
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
ABCDEFGHIJ
1ThedatathatIneedtorearangelookslikethis.Thereareover1000rows.
2
3Course#ClassnameInstructorParticipantParticipantParticipantParticipantParticipantParticipant
4WQ3005MSWordSmithJudySamHenryLarryDiane
5WQ2145MSAccessSamHenrySimonPeterNancy
6WQ3211DataentryJohnPeterPatti
7
8Ineedtotransposetheparticipantsineachclassfromrowstocolumns,butleaveeverythingelseinrowslikethis.
9
10Course#ClassnameInstructorParticipant
11WQ3005MSWordSmithJudy
12Sam
13Henry
14Larry
15Diane
16WQ2145MSAccessSamHenry
17Simon
18Peter
19Nancy
20WQ3211DataentryJohnPeter
21Patti
Sheet1

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

Excel Facts

Did you know Excel offers Filter by Selection?
Add the AutoFilter icon to the Quick Access Toolbar. Select a cell containing Apple, click AutoFilter, and you will get all rows with Apple

Andrew Poulsom

MrExcel MVP
Joined
Jul 21, 2002
Messages
73,092
Try this:

Code:
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

New Member
Joined
Sep 24, 2002
Messages
3
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

MrExcel MVP
Joined
Jul 21, 2002
Messages
73,092
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:

Code:
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
 

Forum statistics

Threads
1,148,190
Messages
5,745,246
Members
423,938
Latest member
manilaphilips

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Top