Transposing based on cell value

  • Thread starter Thread starter karim
  • Start date Start date
K

karim

Hi,
I have 30,000 rows of data (exported from a text file) in the following
manner:
Date: xxx
Name:xxx
Shift:xxx

Category A
line 1
line 2
line 3
etc...

Category B
line 1
line 2
line 3
etc..

and I want to convert the data into columns:

Date Name Shift Category A Category B
line 1
line 2
line 3

Any suggestions on how to do that?

Thanks in advance
Karim
 
A few questions:

Are there multiple Date, Name, and Shifts?
Are the lines variable after the Categories? (perhaps 50 under A but only 25
under B)
Is there a space between the last line in A and the first line for B?

I need a clearer picture to give some useful ideas. Thanks!

-SA
 
Karim,

All this data is in the first column? Is it all the same pattern
Date,Name,Shift,CategoryA,CategoryB-then repeat?
 
there are multiple dates (every year day)
four or five different names and three shifts
the lines after the categories are variables and are not fixed by category
too:
so it can be 5 lines for a specific date/category and 10 lines for other
date/category

Hope that this clarified the picture a bit

Thanks,
Karim
 
All the data is in the first column. the pattern repeats, however the pattern
size is different because the number of lines per category varies.

There are blank lines between categories

Thanks,
Karim
 
Hi Karim,

I'm working on a solution and have another question. Do you want the Date,
Name, and Shift to be copied down to every line or just on the first row
under the category headers? Thanks for the clarification.

-SA
 
Hi SA,
It would be nice if they are copie down to every line. if this will
complicate things, I can do it manually
Thank you very much
Karim
 
OK, so the following works for what I have set up. Because I can't see what
you have exactly, I would recommend saving a backup. ;)

Let me know if it doesn't work!

-SA

PS. Mind the text wrapping.

Option Explicit
Sub Save_Time()

Dim glcount, j, m, n As Integer
Dim startspot, nextspot As Range

j = 0

Set startspot = Range("A1") 'or wherever you start
Set nextspot = Range("A1")

Do
Set startspot = startspot.Offset(j, 0)
If nextspot = "" Then Exit Do
nextspot.Select
ActiveCell.Offset(1, 0).Cut Destination:=startspot.Offset(0, 1)
ActiveCell.Offset(0, 0).Cut Destination:=startspot.Offset(0, 0)
ActiveCell.Offset(2, 0).Cut Destination:=startspot.Offset(0, 2)
startspot.Offset(1, 1).Value = Right(startspot.Offset(0, 1).Value,
Len(startspot.Value) - 6)
startspot.Offset(1, 0) = Right(startspot.Offset(0, 0).Value,
Len(startspot.Value) - 6)
startspot.Value = Left(startspot.Value, 4)
startspot.Offset(0, 1).Value = Left(startspot.Offset(0, 1).Value, 4)
startspot.Offset(1, 2).Value = Right(startspot.Offset(0, 2).Value,
Len(startspot.Offset(0, 2).Value) - 7)
startspot.Offset(0, 2).Value = Left(startspot.Offset(0, 2).Value, 5)

Set nextspot = ActiveCell.Offset(4, 0)
nextspot.Select
Set nextspot = ActiveCell.End(xlDown).Offset(2, 0)

With ActiveCell
m = Range(.Offset(0, 0), .End(xlDown)).Rows.Count
End With

ActiveCell.Resize(m, 1).Select
Selection.Cut Destination:=startspot.Offset(0, 3)

nextspot.Select
Set nextspot = ActiveCell.End(xlDown).Offset(2, 0)

With ActiveCell
n = Range(.Offset(0, 0), .End(xlDown)).Rows.Count
End With

ActiveCell.Resize(n, 1).Select
Selection.Cut Destination:=startspot.Offset(0, 4)

j = j + Application.Max(n, m)

Loop

End Sub
 
I'm gone for the night starting in 2min. I'll check back tomorrow and see if
you've figured anything out or if someone else has looked at it. Until
then... :)
 
Hi SA,
I couldn't fix it and it only does the first two rows and stops with the
error message "invalid procedure call"
Thanks again
Karim
 
Hmm... I'm not sure what the problem is. I'll start a new post and see if
someone can't enlighten us. :)
 
Karim,

Use these steps and the code below-

Step 1 Create a new Module and place this code in it.
Step 2 Put headings in columns D,E,F,G,& H
ie. Date Name Shift Cat A Cat B

Step 3 Run macro "PutMeInOrder()"
Step 4 validate and delete columns ABC

This will place the data in column A into the proper column. It does not
delete the original data so you can compare.

Hope it is what you need.

'**********************************************
Option Explicit

Public AddressNo As Variant
Public dtDate As String
Public strShift As String
Public strName As String



Sub PutMeInOrder()
Application.ScreenUpdating = False

Range("a1").Select

Do Until ActiveCell = "Stop"

If Left(ActiveCell, 4) = "Date" Then
Call WhoIsIt(1)
ActiveCell.Offset(1, 0).Select
Else
If Left(ActiveCell, 2) = "Name:" Then
ActiveCell.Offset(1, 0).Select
Else
If Left(ActiveCell, 5) = "Shift" Then
ActiveCell.Offset(1, 0).Select
Else
If ActiveCell = "Category A" Then
Call WhoIsIt(2)
ActiveCell.Offset(1, 0).Select
Else
If ActiveCell = "Category B" Then
Call WhoIsIt(3)
ActiveCell.Offset(1, 0).Select
Else
If ActiveCell <> "" Then 'get past the list items
ActiveCell.Offset(1, 0).Select
Else
If ActiveCell = "" Then 'get past the empty cells
ActiveCell.Offset(1, 0).Select
End If
End If
End If
End If
End If
End If
End If

Loop
Application.ScreenUpdating = True
End Sub



Sub WhoIsIt(ItsThem As Integer)

Select Case ItsThem
Case 1
dtDate = (Trim(Mid(ActiveCell, 6, Len(ActiveCell))))
strName = (Trim(Mid(ActiveCell.Offset(1, 0), 6, Len(ActiveCell.Offset(1,
0)))))
strShift = (Trim(Mid(ActiveCell.Offset(2, 0), 7,
Len(ActiveCell.Offset(2, 0)))))
Case 2
ActiveCell.Offset(1, 0).Select
Do Until ActiveCell = ""
AddressNo = ActiveCell.Address
MiCatA (ActiveCell)
Application.Goto Range(AddressNo)
ActiveCell.Offset(1, 0).Select
Loop
Application.Goto Range(AddressNo)
ActiveCell.Offset(1, 0).Select

Case 3
ActiveCell.Offset(1, 0).Select
Do Until ActiveCell = ""
AddressNo = ActiveCell.Address
MiCatB (ActiveCell)
Application.Goto Range(AddressNo)
ActiveCell.Offset(1, 0).Select
Loop
Application.Goto Range(AddressNo)
ActiveCell.Offset(1, 0).Select
Case Else
Exit Sub
End Select


End Sub

Function MiCatA(d As String)
Range("g1").Select
If ActiveCell.Offset(1, 0) <> "" Then
ActiveCell.End(xlDown).Select
ActiveCell.Offset(1, 0).Value = d
ActiveCell.Offset(1, -1) = strShift
ActiveCell.Offset(1, -2) = strName
ActiveCell.Offset(1, -3) = dtDate
Else
ActiveCell.Offset(1, 0).Value = d
ActiveCell.Offset(1, -1) = strShift
ActiveCell.Offset(1, -2) = strName
ActiveCell.Offset(1, -3) = dtDate
End If
End Function

Function MiCatB(n As String)
Range("h1").Select
If ActiveCell.Offset(1, 0) <> "" Then
ActiveCell.End(xlDown).Select
ActiveCell.Offset(1, 0).Value = n
Else
ActiveCell.Offset(1, 0).Value = n
End If
End Function

'******************************************
 
Karim,

One other step I left out.

Step 1.5 place the word "Stop" at row 30001
 
Hey JR,

You have some sweet stuff in here! However, if I may interject, it doesn't
account for the case in which category A and category B have different
lengths. In my solution I have

Application.Max(Category A length, Category B length)

for where to start the next date, name, and shift. Perhaps this will spark
an idea for you. I like your solution!

-SA
 
Thanks SA-


StumpedAgain said:
Hey JR,

You have some sweet stuff in here! However, if I may interject, it doesn't
account for the case in which category A and category B have different
lengths. In my solution I have

Application.Max(Category A length, Category B length)

for where to start the next date, name, and shift. Perhaps this will spark
an idea for you. I like your solution!

-SA
Click to expand...
 
I inquired about what was wrong with my macro but got a different solution
instead.

From Dave Peterson:

Option Explicit
Sub testme()

Dim CurWks As Worksheet
Dim NewWks As Worksheet
Dim FirstRow As Long
Dim oRow As Long
Dim BigRng As Range
Dim SmallArea As Range
Dim NextGroupMustBeFirstCategory As Boolean
Dim RngToCopy As Range
Dim oCol As Long
Dim LinesPerGroup As Long

Set CurWks = Worksheets("Sheet1")
Set NewWks = Worksheets.Add

With CurWks
FirstRow = 1
Set BigRng = .Range(.Cells(FirstRow, "A"), _
.Cells(.Rows.Count, "A").End(xlUp)) _
.Cells.SpecialCells(xlCellTypeConstants)
oRow = 0
LinesPerGroup = 1
For Each SmallArea In BigRng.Areas
If LCase(SmallArea.Cells(1, 1).Value) Like LCase("Date:*") Then
'This is the Date/name/shift group
'Start of a new group.
oRow = oRow + LinesPerGroup
NewWks.Cells(oRow, "A").Resize(1, 5).Value _
= Array("Date", "Name", "Shift", "Category A", "Category
B")

oRow = oRow + 1
'remove "Date: "
NewWks.Cells(oRow, "A").Value _
= Trim(Mid(SmallArea.Cells(1, 1).Value, 6))

'remove "Name: "
NewWks.Cells(oRow, "B").Value _
= Trim(Mid(SmallArea.Cells(2, 1).Value, 6))

'remove "Shift: "
NewWks.Cells(oRow, "C").Value _
= Trim(Mid(SmallArea.Cells(3, 1).Value, 7))

NextGroupMustBeFirstCategory = True
LinesPerGroup = 3
Else
'This is the category A or Category B section.
With SmallArea
If .Cells.Count > LinesPerGroup Then
LinesPerGroup = .Cells.Count
End If
Set RngToCopy = .Resize(.Rows.Count - 1, 1).Offset(1, 0)
End With
If NextGroupMustBeFirstCategory Then
oCol = 4 'column D
'get ready for the category B group
NextGroupMustBeFirstCategory = False
Else
oCol = 5 'column E
End If

RngToCopy.Copy
NewWks.Cells(oRow, oCol).PasteSpecial

End If
Next SmallArea

End With

Application.CutCopyMode = False
NewWks.UsedRange.Columns.AutoFit

End Sub

Seems to work well for what I have set up. Hope it helps!
 
thanks SA
JR

StumpedAgain said:
I inquired about what was wrong with my macro but got a different solution
instead.

From Dave Peterson:

Option Explicit
Sub testme()

Dim CurWks As Worksheet
Dim NewWks As Worksheet
Dim FirstRow As Long
Dim oRow As Long
Dim BigRng As Range
Dim SmallArea As Range
Dim NextGroupMustBeFirstCategory As Boolean
Dim RngToCopy As Range
Dim oCol As Long
Dim LinesPerGroup As Long

Set CurWks = Worksheets("Sheet1")
Set NewWks = Worksheets.Add

With CurWks
FirstRow = 1
Set BigRng = .Range(.Cells(FirstRow, "A"), _
.Cells(.Rows.Count, "A").End(xlUp)) _
.Cells.SpecialCells(xlCellTypeConstants)
oRow = 0
LinesPerGroup = 1
For Each SmallArea In BigRng.Areas
If LCase(SmallArea.Cells(1, 1).Value) Like LCase("Date:*") Then
'This is the Date/name/shift group
'Start of a new group.
oRow = oRow + LinesPerGroup
NewWks.Cells(oRow, "A").Resize(1, 5).Value _
= Array("Date", "Name", "Shift", "Category A", "Category
B")

oRow = oRow + 1
'remove "Date: "
NewWks.Cells(oRow, "A").Value _
= Trim(Mid(SmallArea.Cells(1, 1).Value, 6))

'remove "Name: "
NewWks.Cells(oRow, "B").Value _
= Trim(Mid(SmallArea.Cells(2, 1).Value, 6))

'remove "Shift: "
NewWks.Cells(oRow, "C").Value _
= Trim(Mid(SmallArea.Cells(3, 1).Value, 7))

NextGroupMustBeFirstCategory = True
LinesPerGroup = 3
Else
'This is the category A or Category B section.
With SmallArea
If .Cells.Count > LinesPerGroup Then
LinesPerGroup = .Cells.Count
End If
Set RngToCopy = .Resize(.Rows.Count - 1, 1).Offset(1, 0)
End With
If NextGroupMustBeFirstCategory Then
oCol = 4 'column D
'get ready for the category B group
NextGroupMustBeFirstCategory = False
Else
oCol = 5 'column E
End If

RngToCopy.Copy
NewWks.Cells(oRow, oCol).PasteSpecial

End If
Next SmallArea

End With

Application.CutCopyMode = False
NewWks.UsedRange.Columns.AutoFit

End Sub

Seems to work well for what I have set up. Hope it helps!
Click to expand...
 
You must log in or register to reply here.

Ask a Question

Want to reply to this thread or ask your own question?

You'll need to choose a username for the site, which only take a couple of moments. After that, you can post your question and our members will help you out.

Ask a Question

Similar Threads

I need ONLY subtotals copied to a second sheet 4
Code character limit with Resize or Transpose or cell? 8
Adjusting height of text cells 3
Excel 2013 Merge Data 2
length of line depending on the value of the cell 13
Use a VBA function to return a factor 2
Transpose data 4
Data Validation based on Cell Value 4

Back
Top