[mso] Re: Excel-A Tough One

Cool Code Hutch!!

> Try this macro. It pauses & asks you to select the input 
> range (cells with data to be split). Then it pauses a second 
> time & asks you to select one cell (must be on the same 
> sheet) where the output should start.
>  
> Sub SplitData()
> Dim InRng As Range, OutRng As Range, c As Range Dim CumOffset 
> As Long, x As Long, y As Long Dim TmpStr As String, Fillem As 
> Boolean Dim CurrItem As String, CurrNbr As String Dim 
> StartFill As Long, EndFill As Long Dim NbrArray() As Long 
> Application.InputBox("Select the cells to be split", 
> Type:=8).Select Set InRng = Selection 'Output must be on same 
> sheet as input Application.InputBox("Select the starting cell 
> for output", Type:=8).Select Set OutRng = Selection For Each 
> c In InRng
>     If Len(c.Value) > 0 Then
>         TmpStr = c.Value & ","
>         ReDim NbrArray(0)
>         CurrNbr = vbNullString
>         StartFill = 0
>         EndFill = 0
>         Fillem = False
>         CurrItem = Trim(Left(TmpStr, InStr(1, TmpStr, " ")))
>         For x = 1 To Len(TmpStr)
>             Select Case Mid(TmpStr, x, 1)
>             Case "0", "1", "2", "3", "4", "5", "6", "7", "8", "9"
>                 CurrNbr = CurrNbr & Mid(TmpStr, x, 1)
>             Case ","
>                 If Fillem = False Then
>                     ReDim Preserve NbrArray(UBound(NbrArray) + 1)
>                     NbrArray(UBound(NbrArray)) = CLng(CurrNbr)
>                 Else
>                     EndFill = CLng(CurrNbr)
>                     For y = StartFill To EndFill
>                         ReDim Preserve NbrArray(UBound(NbrArray) + 1)
>                         NbrArray(UBound(NbrArray)) = y
>                     Next y
>                 End If
>                 CurrNbr = vbNullString
>             Case "-"
>                 StartFill = CLng(CurrNbr)
>                 Fillem = True
>                 CurrNbr = vbNullString
>             Case Else
>                 'do nothing
>             End Select
>         Next x
>         For x = (LBound(NbrArray) + 1) To UBound(NbrArray)
>             OutRng.Offset(CumOffset, 0).Value = CurrItem & " 
> " & NbrArray(x)
>             CumOffset = CumOffset + 1
>         Next x
>     End If
> Next c
> cleanup:
> Set InRng = Nothing
> Set OutRng = Nothing
> ReDim NbrArray(0)
> End Sub
> If you are new to macros, this link to Jon Peltier's site may 
> be helpful:
> http://peltiertech.com/WordPress/2008/03/09/how-to-use-someone
> -elses-macro/
>  
> Hope this helps,
>  
> Hutch

*************************************************************
You are receiving this mail because you subscribed to mso@xxxxxxxxxxxxx or 
MicrosoftOffice@xxxxxxxxxxxxxxxx

To send mail to the group, simply address it to mso@xxxxxxxxxxxxx

To Unsubscribe from this group, visit the group's homepage and use the dropdown 
menu at the top.  This will allow you to unsubscribe your email address or 
change your email settings to digest or vacation (no mail).
http://www.freelists.org/webpage/mso

To be able to share files with the group, you must join our Yahoo sister group. 
 This group will not allow for posting of emails, but will allow you to join 
and share problem files, templates, etc.:  
http://tech.groups.yahoo.com/group/MicrosoftOffice . This group is for FILE 
SHARING ONLY.

If you are using Outlook and you see a lot of unnecessary code in your email 
messages, read these instructions that explain why and how to fix it:
http://personal-computer-tutor.com/abc3/v28/greg28.htm
*************************************************************

Other related posts: