Solved

Seperating name and returning matched values

Posted on 2011-09-09
3
175 Views
Last Modified: 2012-05-12
I have a worksheet in Excel 2010 which I am attaching.
In the name column, I have names, dived by a semicolon. The name are lastname, initial.  Some rows have two names, other three.
I cant find a way to divid the names, so that each name it on a seperate row, but that each of these seperate names takes the correct corresponding Date (column B) and Year (column C) with them. names.xlsx
0
Comment
Question by:LiamMcKay
  • 2
3 Comments
 
LVL 5

Expert Comment

by:slycoder
Comment Utility
Add a Sheet2 sheet and give this macro a try


Public Sub breakout()
    Dim mystring, mymonth, myyear As String
    Dim mypos As Integer
   
    ' Turn off screen updating for speed
    Application.ScreenUpdating = False

    ' Setup Sheet 2
    ActiveWorkbook.Sheets("Sheet2").Select
    Range("a1").Select

    ' Start in sheet 1, cell 1
    ActiveWorkbook.Sheets("Sheet1").Select
    Range("a1").Select
   
    ' loop consecutive cells (including header)
   
    Do While ActiveCell.Value <> ""
   
        ' memorize values in row
        mystring = ActiveCell.Value
        mymonth = ActiveCell.Offset(0, 1).Value
        myyear = ActiveCell.Offset(0, 2).Value
   
        ' Find semi-colon
        If InStr(1, mystring, ";") > 0 Then
            ' jump to sheet 2 for input
            ActiveWorkbook.Sheets("Sheet2").Select
           
            ' scan for semi-colons
            Do While InStr(1, mystring, ";") > 0
               
                mypos = InStr(1, mystring, ";")
               
                ' Write information to sheet2
                ActiveCell.Value = Mid(mystring, 1, mypos - 1)
                ActiveCell.Offset(0, 1).Value = mymonth
                ActiveCell.Offset(0, 2).Value = myyear
               
                ' position in next cell
                ActiveCell.Offset(1, 0).Select
               
                ' remove name from string
                mystring = Trim(Mid(mystring, mypos + 1, 999))
            Loop
            ' output last value
            ActiveCell.Value = Mid(mystring, 1, 999)
            ActiveCell.Offset(0, 1).Value = mymonth
            ActiveCell.Offset(0, 2).Value = myyear
           
            ' position in next cell
            ActiveCell.Offset(1, 0).Select
           
            ' Return to sheet 1
            ActiveWorkbook.Sheets("Sheet1").Select
        Else
            ' Write single name/title to sheet 2
            ActiveWorkbook.Sheets("Sheet2").Select
            ActiveCell.Value = mystring
            ActiveCell.Offset(0, 1).Value = mymonth
            ActiveCell.Offset(0, 2).Value = myyear
            ActiveCell.Offset(1, 0).Select
           
            ' Return to sheet 1
            ActiveWorkbook.Sheets("Sheet1").Select
        End If
   
        ' jump to next cell
        ActiveCell.Offset(1, 0).Select
    Loop
   
    ' Turn on screen updating
    Application.ScreenUpdating = True


End Sub
0
 
LVL 92

Accepted Solution

by:
Patrick Matthews earned 125 total points
Comment Utility
The following code seems to work for me.  It posts the results to a new worksheet:


Sub SplitRows()
    
    Dim ArrIn As Variant, ArrOut() As Variant
    Dim LastR As Long
    Dim DestR As Long
    Dim Counter As Long
    Dim Names As Variant
    Dim NameCounter As Long
    
    With ActiveSheet
        LastR = .Cells(.Rows.Count, "a").End(xlUp).Row
        ArrIn = .Range("a1:c" & LastR).Value
    End With
    
    For Counter = 1 To UBound(ArrIn, 1)
        If Counter = 1 Then
            DestR = 1
            ReDim ArrOut(1 To 3, 1 To 1) As Variant
            ArrOut(1, 1) = ArrIn(1, 1)
            ArrOut(2, 1) = ArrIn(1, 2)
            ArrOut(3, 1) = ArrIn(1, 3)
        Else
            Names = Split(ArrIn(Counter, 1), ";")
            For NameCounter = LBound(Names) To UBound(Names)
                DestR = DestR + 1
                ReDim Preserve ArrOut(1 To 3, 1 To DestR)
                ArrOut(1, DestR) = Trim(Names(NameCounter))
                ArrOut(2, DestR) = ArrIn(Counter, 2)
                ArrOut(3, DestR) = ArrIn(Counter, 3)
            Next
        End If
    Next
    
    Worksheets.Add
    Range("a1:c" & DestR).Value = Application.Transpose(ArrOut)
    Range("1:1").Font.Bold = True
    Columns.AutoFit
    
End Sub

Open in new window

0
 
LVL 92

Expert Comment

by:Patrick Matthews
Comment Utility
Friendly aside to slycoder:

>>    Dim mystring, mymonth, myyear As String

That is a legal statement, but it actually makes mystring and mymonth Variants, and not Strings.  Rather, you
probably meant to use:

    Dim mystring As String, mymonth As String, myyear As String

:)

Patrick
0

Featured Post

Find Ransomware Secrets With All-Source Analysis

Ransomware has become a major concern for organizations; its prevalence has grown due to past successes achieved by threat actors. While each ransomware variant is different, we’ve seen some common tactics and trends used among the authors of the malware.

Join & Write a Comment

Approximate matching with VLOOKUP and MATCH seems to me to be a greatly under-used technique, and one which is vital for getting good performance out of large lookups. Until recently I would always have advised using an exact match for simplicity an…
Improved? Move/Copy Add-in Replacement - How to avoid the annoying, “A formula or sheet you want to move or copy contains the name XXX, which already exists on the destination worksheet.” David Miller (dlmille)  It was one of those days… I wa…
The viewer will learn how to create two correlated normally distributed random variables in Excel, use a normal distribution to simulate the return on different levels of investment in each of the two funds over a period of ten years, and, create a …
This Micro Tutorial will demonstrate in Microsoft Excel how to add style and sexy appeal to horizontal bar charts.

744 members asked questions and received personalized solutions in the past 7 days.

Join the community of 500,000 technology professionals and ask your questions.

Join & Ask a Question

Need Help in Real-Time?

Connect with top rated Experts

17 Experts available now in Live!

Get 1:1 Help Now