Excel VBA - Simplify a complex Row

[StylinEric]

O.k. my second time posting here!! Thanks agian everyone for all thie
help

O.k. here is my issue

I worksheet with these column headings

CompanyID
CompanyName
Name 1
Title 1
Name 2
Title 2
Name 3
Title 3
etc..

When I say etc.. I mean it keeps going on with the name, title sequenc
till it gets to around name 27, title 27. However not all the column
are populated in some rows as some companies only have 5 or 6 peopl
listed.

So what do I want to do...

I want to be able to have one sheet list all the above information
but with only 4 column headings, possibly more if it is possible t
concatinate the name into first, last, middle, suffic, in the process.
But basically I want

CompanyID, CompanyName, Name, Title


Agian, I appreciate everyone's help here. You guys rock!!

ColumnID, Compan

 

[Bob Phillips]

Hi Eric,

Here's a shot

Sub MoveData()
Dim i As Long
Dim j As Long
Dim iNewRow As Long
Dim oWs As Worksheet

Set oWs = Worksheets("Sheet2")

iNewRow = 1
For i = 1 To Cells(Rows.Count, "A").End(xlUp).Row
For j = 3 To Cells(i, Columns.Count).End(xlToLeft).Column Step 2
Cells(i, "A").Copy Destination:=oWs.Cells(iNewRow, "A")
Cells(i, "B").Copy Destination:=oWs.Cells(iNewRow, "B")
Cells(i, j).Copy Destination:=oWs.Cells(iNewRow, 3)
Cells(i, j + 1).Copy Destination:=oWs.Cells(iNewRow, 4)
iNewRow = iNewRow + 1
Next j
Next i

End Sub

--

HTH

Bob Phillips
... looking out across Poole Harbour to the Purbecks
(remove nothere from the email address if mailing direct)

 

[Bernie Deitrick]

Stylin,

Try the macro below. Assumptions are that the database starts in Cell A1,
there are no blanks in column A, and your names and titles are contiguous,
scrunched to the left.

HTH,
Bernie
MS Excel MVP

Sub TryNow()
Dim myCell As Range
Dim myInput As Range
Dim i As Integer
Dim j As Integer

Set myInput = Range("A1").CurrentRegion.Columns(1).Cells

Set myCell = Range("A65536").End(xlUp)(3)
myCell(1, 1).Value = "CompanyID"
myCell(1, 2).Value = "CompanyName"
myCell(1, 3).Value = "Name"
myCell(1, 4).Value = "Title"

For i = 2 To myInput.Cells.Count
For j = 1 To 27
If myInput(i, 2 * j + 1).Value <> "" Then
Set myCell = Range("A65536").End(xlUp)(2)
myCell(1, 1).Value = myInput(i, 1).Value
myCell(1, 2).Value = myInput(i, 2).Value
myCell(1, 3).Value = myInput(i, 2 * j + 1).Value
myCell(1, 4).Value = myInput(i, 2 * j + 2).Value
Else
Exit For
End If
Next j
Next i

myInput.EntireRow.Delete
Range("1:1").EntireRow.Delete
End Sub

 

[jeff]

StylinEric,

If you'll send your email address to me, I'll
send you (overnight)some instructions and a macro I built
which should just about do it for you if you can wait
that long.

Send to (remove nospam) (e-mail address removed).

--although I think I saw an elegant solution yesterday or
the day before by one of the MVPs which is very close -
so you might try searching here first.

jeff

 

[StylinEric]

WOW!!!

All your solutions seemed to work!!, though both a little different
they worked fabulously. Thank you so much for all the help guys!

Jeff, don't worry about this one, but I'll be sure to email you shoul
I have any other questions on it

Thanks Agian!!

Eri

 

[jeff]

Eric,

Glad they work for you - mine was similar.
but write anytime.
jeff