Combine and Convert to Multiple Rows

[Jeff Gross]

I have several columns of data such as follows:

A B C D E
Op # Op Desc Mechanical Electrical Fire
10 Desc #1 mech 1 elect 1
10 Desc #2 elect 2 fire 1
20 Desc #3 mech 2 fire 2
20 Desc #4 mech 3 elect 3

The end result must be a sort of the data by Op # and then by the hazard
category (columns C-E) with each hazard category on it's own row as follows:

10 Desc #1 mech 1
10 Desc #1 elect 1
10 Desc #2 elect 2
10 Desc #2 fire 1
20 Desc #3 mech 2
20 Desc #3 fire 2
20 Desc #4 mech 3
20 Desc #4 elect 3

Any ideas? There could be up to 300 original versions of the rows of data
to sort this way.

Thanks for any help.

 

[Joel]

this is code I wrote yesterday for another posting. I modified yesterdays
code becasue you only have two columns that need to be copied to every row
and yesterdays posting had 3 columns that need to be copied to every row.
the code is copying the data from sheet1 and putting the results in sheet2.
The macro runs faster if you put the data into a new worksheet.

Sub Transpose()

Set SourceSht = Sheets("sheet1")
Set DestSht = Sheets("sheet2")
With DestSht
.Range("A1") = "ID"
.Range("B1") = "Surname"
.Range("C1") = "Name"
.Range("D1") = "Choises"
End With

With SourceSht
SourceRow = 2
DestRow = 2
Do While .Range("A" & SourceRow) <> ""
'set Copyrange to equal columns A - C
Set CopyRange = _
.Range("A" & SourceRow & ":B" & SourceRow)
ColCount = 3
Do While .Cells(SourceRow, ColCount) <> ""
CopyRange.Copy _
Destination:=DestSht.Range("A" & DestRow)
Choice = .Cells(SourceRow, ColCount).Value
DestSht.Range("C" & DestRow) = Choice
DestRow = DestRow + 1
ColCount = ColCount + 1
Loop
SourceRow = SourceRow + 1
Loop
End With
End Sub

 

[Jeff Gross]

Thanks alot Joel.

I was actually looking at that post before posting my own. The code you
provided is putting blank rows in when there is a blank in the cell of a
particular column. I could do a subsequent re-sort and that would remove
them but if I could just get the code to not put a blank row in when there is
a blank cell, that would be very helpful.

Jeff

 

[Patrick Molloy]

copy this code to a standard module.



Option Explicit
Sub sortdata()
Dim lastrow As Long
Dim rw As Long
lastrow = Range("A1").End(xlDown).Row

'copy column A twice
Range(Range("A1"), Range("B1").End(xlDown)).Copy
Range("A1").End(xlDown).Offset(1).PasteSpecial xlPasteAll
Range("A1").End(xlDown).Offset(1).PasteSpecial xlPasteAll

'copy column D to C below existing B
Range(Range("D1"), Cells(lastrow, "D")).Copy
Range("C1").Offset(lastrow).PasteSpecial xlPasteAll

'copy column E to C below existing B
Range(Range("E1"), Cells(lastrow, "E")).Copy
Range("C1").Offset(lastrow * 2).PasteSpecial xlPasteAll

Columns(4).Cells.Clear
Columns(5).Cells.Clear

For rw = Range("A1").End(xlDown).Row To 2 Step -1
If Cells(rw, "C") = "" Then
Rows(rw).Delete
End If
Next
End Sub

 

[Joel]

I don't think those cells are really empty. Try this change

from:
Do While .Cells(SourceRow, ColCount) <> ""
to:
Do While trim(.Cells(SourceRow, ColCount)) <> ""

 

[Joel]

I looked at your data and didn't realize the differences between the code I
provided and then posting I responded to yesterday. Try these imporvements

Sub Transpose()

Set SourceSht = Sheets("sheet1")
Set DestSht = Sheets("sheet2")
With DestSht
.Range("A1") = "Op #"
.Range("B1") = "OP Desc"
.Range("C1") = "Hazard"
End With

With SourceSht
LastCol = .Cells(1, Columns.Count).End(xlToLeft).Column
SourceRow = 2
DestRow = 2
Do While .Range("A" & SourceRow) <> ""
'set Copyrange to equal columns A - C
Set CopyRange = _
.Range("A" & SourceRow & ":B" & SourceRow)
For Colcount = 3 To LastCol
If .Cells(SourceRow, Colcount) <> "" Then
CopyRange.Copy _
Destination:=DestSht.Range("A" & DestRow)
Hazard = .Cells(SourceRow, Colcount).Value
DestSht.Range("C" & DestRow) = Hazard
DestRow = DestRow + 1
End If
Next Colcount
SourceRow = SourceRow + 1
Loop
End With
End Sub

 

[Jeff Gross]

You're right - the cells are not truely blank but have a formula. Would a
paste special values only take care of that issue?

 

[Joel]

Lets try putting the trim into the new code. I try a test a found a formula
that is returning nothing ("") two double quotes with no spaces will be
recognized with the following statment as being true.

If .Cells(SourceRow, Colcount) <> "" Then

It is not the formula that causing the problem but the value that is being
returned by the formula. Probably is returning a non-blank string. Using
trim will remove any blanks.


from
If .Cells(SourceRow, Colcount) <> "" Then
to
If Trim(.Cells(SourceRow, Colcount)) <> "" Then

 

[Jeff Gross]

Joel - thanks for all your help.

The code works except for one thing. The Op # is being properly copied down
for each row but the Op Description is not being properly copied. It copies
directly from sheet1 b2 and b3 to sheet2 b2 and b3.

Any ideas?

Jeff

 

[Joel]

It is probably a formula try this change

from
CopyRange.Copy _
Destination:=DestSht.Range("A" & DestRow)
to
CopyRange.Copy
DestSht.Range("A" & DestRow).PasteSpecial _
paste:=xlPasteValues

 

[Jeff Gross]

That was it - thanks alot for your help.

Jeff

It is probably a formula try this change

from
CopyRange.Copy _
Destination:=DestSht.Range("A" & DestRow)
to
CopyRange.Copy
DestSht.Range("A" & DestRow).PasteSpecial _
paste:=xlPasteValues

 

[Jeff Gross]

Hi Joel-

I opened the file this morning and when I run the code, I keep getting a
compile error. Any ideas?

The exact error is: Compile error: Expected Function or variable

Thanks.

Jeff

 

[Jeff Gross]

Joel - please disregard the post I just made - I had added some code and
didn't realize I had named it the same as in this code. Once I removed it,
it worked again.

Jeff