Reorganising data - macro needed?

[gavfrancis]

I seem to be going round in circles trying to get this solved and just
cannot put my finger on it. Basically I have a sheet set out like this
-

Company name Location Product1 Product2 Product3
Company x USA Yes No No
Company y UK Yes Yes No
Company z AUS No No Yes
.......

What I'd like to do is to retain the companies in rows but to have one
row per product that they sell. e.g -

USA Company x Product1
UK Company y Product1
Product2
AUS Company z Product3

I presume that I might have to copy the "UK" and "Company y" on row 3
but for cosmetic sake would prefer not to. I've tried putting the data
into a Pivot table but this doesn't really work when "No" is the value.
I presume that I need to do some kind of validation and then copy/paste
but I'm not sure where to go.

Thanks.

 

[Guest]

Hi,

Try this:

Sub Reorganise()

Dim ws1 As Worksheet
Dim ws2 As Worksheet
Dim ws2rng As Range
Dim lastrow As Long, r As Long, c As Integer, lastcol As Integer

Set ws1 = Worksheets("sheet1")
Set ws2 = Worksheets("sheet2")

Set ws2rng = ws2.Range("a2")
ws2rng.Offset(-1, 0).Resize(1, 3) = Array("Location", "Company Name",
"Product")

With ws1
lastrow = .Cells(Rows.Count, 1).End(xlUp).Row
For r = 2 To lastrow
lastcol = .Cells(r, Columns.Count).End(xlToLeft).Column
ws2rng = .Cells(r, 2)
ws2rng.Offset(0, 1) = .Cells(r, 1)
Set ws2rng = ws2rng.Offset(0, 2)
For c = 3 To lastcol
If Trim(UCase(.Cells(r, c))) = "YES" Then
ws2rng = .Cells(1, c)
Set ws2rng = ws2rng.Offset(1, 0)
End If
Next c
Set ws2rng = ws2rng.Offset(0, -2)
Next r
End With

End Sub

 

[gavfrancis]

Hi Toppers, thanks for your effort. This code is getting there but
what it seems to do is copy the information into Sheet2 on the same
lines, e.g it does not go down to the next row, instead all of the
information overwrites the previous.

 

[Guest]

Hi,
This will happen if the Product column doesn't contain "YES" or
"Yes" without any leading/trailing blanks; it failed when I copied your data
from the NG unless I changed the Product columns as above. If necessary
change the line:

If Trim(UCase(.Cells(r, c))) = "YES" Then

HTH

 

[gavfrancis]

Yes, that was it. So many thanks for your help.

Gavin