VBA for Copy/Paste-Transpose for ranges that vary in size

[j611obrien]

Hello,
I have a list of data with 6000 names and various pieces of information about that individual.

John Smith
Company A
555-555-1234
555-555-2000
[email protected]
MikeJones
CompanyB
555-123-4567
[email protected]


My goal here is to take the above information and put it into table format. The issue that I'm having is that:
1) I'm a novice to macros
2) My amount of fields for a given individual isn't always the same. In the above example John Smith has 5 fields and Mike Jones has 4 fields. This results in a phone number being the 4th piece of information for John Smith and an email address for Mike Jones.

Thanks in advance for the help!!

How do I go about making a macro that copies the indivuals information into a table where all fields are under the appropriate table column?

[YasserKhalil]

Can you upload sample of your workbook?

[j611obrien]

Done! You'll notice that some of the individuals (highlighted in yellow) have a "show my listings", yet others do not. So some names have 7 lines of information, others have 8.
" ,

[j611obrien]

Can you upload sample of your workbook?

Done! You'll notice that some of the individuals (highlighted in yellow) have a "show my listings", yet others do not. So some names have 7 lines of information, others have 8.
" ,

[YasserKhalil]

Do you need to deal with sheet1?
It would be easier if the first block starts with colored cell as you attached but I think you put these colors for illustration purposes

[j611obrien]

Do you need to deal with sheet1?
It would be easier if the first block starts with colored cell as you attached but I think you put these colors for illustration purposes

Whatever is easiest. Correct, I just highlighted the cells as a visual.

[JOHN H. DAVIS]

Does this help?

Please Login or Register  to view this content.

[mehmetcik]

Please Login or Register  to view this content.

[j611obrien]

Hello,
My apologies for the delayed response. Your macro works about 1/2 the time. Sometimes I get a "Run-time Error '9': Subscript out of range". When I step into the VBA the MyArray(Count, Pos) = T is highlighted. So I assume it's getting hung up there. Can you assist? Thanks.

Sub SWMRIC()
'
' SWMRIC Macro
'

With ActiveSheet.UsedRange
SR = .Row
SC = .Column
LR = .Rows(UBound(.Value)).Row
LC = .Columns(UBound(.Value, 2)).Column
End With

'Write Titles
Titles = Array("Name", "Company", "Tel.1", "Tel.2", "Email", "See.1", "See.2", "Member Of:")
Range("B2:I2").Value = Titles
'How Many Entries do we have?
Entries = Application.WorksheetFunction.CountIf(Range("A:A"), "*@*")

ReDim MyArray(Entries - 1, 7)

'Read Data into VBA
InputA = Range(Cells(SR, SC), Cells(LR, SC)).Value

StartPos = 1

'We need to do this for every Entry.
For Count = 0 To Entries - 1

Pos = 0
TFlag = 0

EndPos = Range(Cells(StartPos + 1, 1), Cells(LR, 1)).Find("Member Of ", LookIn:=xlValues, Lookat:=xlPart).Row - 1

'We need to do this for every line of the entry.

For Count2 = StartPos To EndPos
T = InputA(Count2, 1)
If InStr(T, "@") > 0 Then MyArray(Count, 4) = T: GoTo Skip
If Left(T, 1) = "(" Then MyArray(Count, 2 + TFlag) = T: TFlag = 1: GoTo Skip
If Left(T, 9) = "Member of" Then MyArray(Count, 7) = T: GoTo Skip
MyArray(Count, Pos) = T: Pos = Pos + 1: If Pos = 2 Then Pos = 5

Skip:

Next

StartPos = EndPos + 1
Next

'Save The Sorted Data to Spreadsheet
Range("B3:I" & Entries + 2).Value = MyArray
End Sub