Formulas for separating cell contents in to four separate cells

[knpaddac]

I have 1 column with over 50,000 rows containing data strings (they are actually basketball game scores) that are currently formatted like this:

Teama ##-## Teamb

The '#' represent numeric digits, although many were interpreted as letters or other symbols by OCR software. These start in cell E2. I am wanting to use formulas to separate that data from E2 out into the four cells to the right looking something like this:
F2-- Teama
G2-- ## (the first score)
H2-- ## (second score)
I2-- Teamb

There is some inconsistency in that sometimes the ## is actually a single digit or even three, and there are also names that have spaces or hyphens in the middle (West Haven or Spencer-Green). Basically I am looking for any help to create formulas that will do the bulk of the work and then I assume that I will have to go back and do some manipulation of those that do not fit exactly.

Any help is appreciated.

 

[knpaddac]

Okay, so what specifically in that code do I need to change? All references to "A" or "A1" get changed to "E"?

I think the issue is simple, the code is running on column A the words to split are on column E

 

[Rick Rothstein]

I think the issue is simple, the code is running on column A the words to split are on column E

I haven't downloaded your file yet, but it that is the problem, then simply change the red highlighted A's to E's (you might also need to change the green highlighted 1 to the actual starting row number for your data if it does not start on Row 1)... you should also change the blue highlighted B's to the column letter designation where you want your output to go to.

[table="width: 500"]
[tr]
	[td]Sub SplitTeamsAndScores()
  Dim R As Long, X As Long, Txt As String, Data As Variant, Answer As Variant
  Data = Range("[B][COLOR="#FF0000"]A[/COLOR][/B][B][COLOR="#008000"]1[/COLOR][/B]", Cells(Rows.Count, "[B][COLOR="#FF0000"]A[/COLOR][/B]").End(xlUp).Offset(1))
  ReDim Answer(1 To UBound(Data), 1 To 1)
  For R = 1 To UBound(Data)
    Txt = Replace(Replace(Data(R, 1), " -", "-"), "- ", "-")
    For X = 1 To Len(Txt)
      If Mid(Txt, X, 3) Like "#-#" Then
        Txt = Left(Txt, X) & Chr(1) & Mid(Txt, X + 2)
        Txt = Application.Replace(Txt, InStrRev(Txt, " ", X), 1, Chr(1))
        Txt = Application.Replace(Txt, InStr(X, Txt, " "), 1, Chr(1))
        Answer(R, 1) = Txt
      End If
    Next
  Next
  Range("[B][COLOR="#0000FF"]B[/COLOR][/B]1").Resize(UBound(Answer)) = Answer
  Columns("[B][COLOR="#0000FF"]B[/COLOR][/B]").TextToColumns , xlDelimited, , , False, False, False, False, True, Chr(1)
End Sub[/td]
[/tr]
[/table]

 

[knpaddac]

Getting the 'runtime error 13 type mismatch'. When I click debug the highlighted line is Txt = Application.Replace(Txt, InStrRev(Txt, " ", X), 1, Chr(1))

I haven't downloaded your file yet, but it that is the problem, then simply change the red highlighted A's to E's (you might also need to change the green highlighted 1 to the actual starting row number for your data if it does not start on Row 1)... you should also change the blue highlighted B's to the column letter designation where you want your output to go to.

[TABLE="width: 500"]
<tbody>[TR]
[TD]Sub SplitTeamsAndScores()
  Dim R As Long, X As Long, Txt As String, Data As Variant, Answer As Variant
  Data = Range("[B][COLOR=#FF0000]A[/COLOR][/B][B][COLOR=#008000]1[/COLOR][/B]", Cells(Rows.Count, "[B][COLOR=#FF0000]A[/COLOR][/B]").End(xlUp).Offset(1))
  ReDim Answer(1 To UBound(Data), 1 To 1)
  For R = 1 To UBound(Data)
    Txt = Replace(Replace(Data(R, 1), " -", "-"), "- ", "-")
    For X = 1 To Len(Txt)
      If Mid(Txt, X, 3) Like "#-#" Then
        Txt = Left(Txt, X) & Chr(1) & Mid(Txt, X + 2)
        Txt = Application.Replace(Txt, InStrRev(Txt, " ", X), 1, Chr(1))
        Txt = Application.Replace(Txt, InStr(X, Txt, " "), 1, Chr(1))
        Answer(R, 1) = Txt
      End If
    Next
  Next
  Range("[B][COLOR=#0000FF]B[/COLOR][/B]1").Resize(UBound(Answer)) = Answer
  Columns("[B][COLOR=#0000FF]B[/COLOR][/B]").TextToColumns , xlDelimited, , , False, False, False, False, True, Chr(1)
End Sub[/TD]
[/TR]
</tbody>[/TABLE]

 

[Dryver14]

I got this error when I tried to run the code on 1 line of data, if you are testing it, try it on a few more lines than 1

 

[knpaddac]

Still have to think I am doing something wrong, because I cannot get it to go.

I got this error when I tried to run the code on 1 line of data, if you are testing it, try it on a few more lines than 1

 

[Wade Mangan]

I'm not sure I should jump in here, since there is a solution that is working and it is a thread for VBA, but it seems to me this is the type of scenario that PowerQuery was built for. PQ is found on the data tab in Excel 2016. If you are unfamiliar with PQ, it is worth investing a little time to learn a bit about it. The nice thing is, if you set up a query for this 50k row file, next time you open the updated file, it will automatically format the file just by hitting refresh.

My apologies if I have broken any rules regarding posting on a thread.

 

[MartyS]

Does this help?


https://www.dropbox.com/s/u16hr9y91dtrf7a/Upload_of_year_by_year_games_WithDataCleanMacro.xlsm?dl=0


The previous code (incredibly neat / supercool) has an assumption that there is a space before the first number and when it can't find it and tries to do an Application.Replace on a <space> character that doesn't exist, it runtimes-out! (error msg).

Whilst the above isn't perfect (the variety of data errors are wonderful!).. it does convert a lot.

Handy, maybe, until previous poster gives more elegant solution!

 

[Rick Rothstein]

The previous code (incredibly neat / supercool) has an assumption that there is a space before the first number and when it can't find it and tries to do an Application.Replace on a <space> character that doesn't exist, it runtimes-out! (error msg).

I downloaded the OP's file and you are correct, some of the entries have no space in front of the number in front of the dash. Here is new code which works around that situation...

[table="width: 500"]
[tr]
	[td]Sub SplitTeamsAndScores()
  Dim R As Long, X As Long, Z As Long, Dash As Long
  Dim Txt As String, Data As Variant, Answer As Variant
  Data = Range("E2", Cells(Rows.Count, "E").End(xlUp).Offset(1))
  ReDim Answer(1 To UBound(Data), 1 To 4)
  For R = 1 To UBound(Data)
    Txt = Replace(Replace(Data(R, 1), " -", "-"), "- ", "-")
    For X = 1 To Len(Txt)
      If Mid(Txt, X, 3) Like "#-#" Then
        Dash = X + 1
        For Z = Dash - 1 To 1 Step -1
          If Mid(Txt, Z, 2) Like "[!0-9]#" Then
            Answer(R, 1) = Trim(Left(Txt, Z - 1))
            Answer(R, 2) = Mid(Txt, Z + 1, Dash - Z - 1)
            Exit For
          End If
        Next
        For Z = Dash + 1 To Len(Txt)
          If Mid(Txt, Z, 2) Like "#[!0-9]" Then
            Answer(R, 3) = Mid(Txt, Dash + 1, Z - Dash)
            Answer(R, 4) = Trim(Mid(Txt, Z + 1))
            Exit For
          End If
        Next
        Exit For
      End If
    Next
  Next
  Columns("F:I").ClearContents
  Columns("F:I").NumberFormat = "General"
  Range("F2").Resize(UBound(Answer), 4) = Answer
End Sub[/td]
[/tr]
[/table]

 

[knpaddac]

That did it! Thank you very much. Now I just have to clean up the odds and ends that the OCR screwed up, but this has saved me tons of time. Thank you very much to everybody that helped.

I downloaded the OP's file and you are correct, some of the entries have no space in front of the number in front of the dash. Here is new code which works around that situation...

[TABLE="width: 500"]
<tbody>[TR]
[TD]Sub SplitTeamsAndScores()
  Dim R As Long, X As Long, Z As Long, Dash As Long
  Dim Txt As String, Data As Variant, Answer As Variant
  Data = Range("E2", Cells(Rows.Count, "E").End(xlUp).Offset(1))
  ReDim Answer(1 To UBound(Data), 1 To 4)
  For R = 1 To UBound(Data)
    Txt = Replace(Replace(Data(R, 1), " -", "-"), "- ", "-")
    For X = 1 To Len(Txt)
      If Mid(Txt, X, 3) Like "#-#" Then
        Dash = X + 1
        For Z = Dash - 1 To 1 Step -1
          If Mid(Txt, Z, 2) Like "[!0-9]#" Then
            Answer(R, 1) = Trim(Left(Txt, Z - 1))
            Answer(R, 2) = Mid(Txt, Z + 1, Dash - Z - 1)
            Exit For
          End If
        Next
        For Z = Dash + 1 To Len(Txt)
          If Mid(Txt, Z, 2) Like "#[!0-9]" Then
            Answer(R, 3) = Mid(Txt, Dash + 1, Z - Dash)
            Answer(R, 4) = Trim(Mid(Txt, Z + 1))
            Exit For
          End If
        Next
        Exit For
      End If
    Next
  Next
  Columns("F:I").ClearContents
  Columns("F:I").NumberFormat = "General"
  Range("F2").Resize(UBound(Answer), 4) = Answer
End Sub[/TD]
[/TR]
</tbody>[/TABLE]