Urgent - Excel/VBa help - identify text in cell and sort

[nt_beans]

All,

My original spreadhsheet with user name, location and package is in this format:

First	Last	Location	Package
Andrew	Wan	Chicago	EX - RT CBOT, EXD - DELCOMEX, EXD - DEL NYMEX, NTWK WB BASE - QUOTES AG/COMMODITY, PUBLIC DEFAULTS <tbody> </tbody>
Nicole	Andy	New York	EX - RT CBOT, EX - RT CME, EX - RT WINNIPEG, EXD - DEL COMEX, EXD - DEL NYMEX, NTWK WB BASE - QUOTES EN, PUBLIC DEFAULTS <tbody> </tbody>
Ram	Sinha	Seattle	CASH MARKETS EDITION (PXCSH), , EX - RT CME, EX - RT EURONEXT ENCOM, EX - RT ICE (FORMERLY IPE), EX - RT ICE LIFFE, EX - RT MALAYSIA CPO, EX - RT NYBOT, EX - RT NYMEX, , LDP REPORTS (NPLDP), NTWK PRO BASE - AG/COMM EXD, <tbody> </tbody>

<tbody>
</tbody>

I want to format the above spreadsheet so if Col - Package contain either words CBOT or COMEX or NYMEX or CME then i want a new sheet with following information

First	Last	Location	Package
Andrew	Wan	Chicago	CBOT
Andrew	Wan	Chicago	COMEX
Andrew	Wan	Chicago	NYMEX
Nicole	Andy	New York	CBOT
Nicole	Andy	New York	CME
Nicole	Andy	New York	Comex
Nicole	Andy	New York	NYMEX
Ram	Sinha	Seattle	CME
Ram	Sinha	Seattle	NYMEX

<tbody>
</tbody>

Thanks in advance for helping in this project

 

[Rick Rothstein]

All,

My original spreadhsheet with user name, location and package is in this format:

First	Last	Location	Package
Andrew	Wan	Chicago	EX - RT CBOT, EXD - DELCOMEX, EXD - DEL NYMEX, NTWK WB BASE - QUOTES AG/COMMODITY, PUBLIC DEFAULTS <tbody> </tbody>

<tbody>
</tbody>

Is the above Package text correct as shown... there is no space between the "DEL" and the "COMEX"?

 

[nt_beans]

Is the above Package text correct as shown... there is no space between the "DEL" and the "COMEX"?

My apologies there is indeed a space between "DEL" and "COMEX" .

 

[mumps]

There may be a more elegant way but this seems to work. Results on Sheet2.

Sub SplitCell()
    Application.ScreenUpdating = False
    Dim LastRow As Long
    LastRow = Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
    Dim i As Long
    Dim splitPkg As Variant
    Dim pkg As Range
    For Each pkg In Range("D2:D" & LastRow)
        splitPkg = Split(pkg, ",")
        For i = LBound(splitPkg) To UBound(splitPkg)
            If splitPkg(i) Like "*CBOT*" Then
                Sheets("Sheet2").Cells(Rows.Count, "A").End(xlUp).Offset(1, 0) = pkg.Offset(0, -3)
                Sheets("Sheet2").Cells(Rows.Count, "B").End(xlUp).Offset(1, 0) = pkg.Offset(0, -2)
                Sheets("Sheet2").Cells(Rows.Count, "C").End(xlUp).Offset(1, 0) = pkg.Offset(0, -1)
                Sheets("Sheet2").Cells(Rows.Count, "D").End(xlUp).Offset(1, 0) = "CBOT"
            ElseIf splitPkg(i) Like "*COMEX*" Then
                Sheets("Sheet2").Cells(Rows.Count, "A").End(xlUp).Offset(1, 0) = pkg.Offset(0, -3)
                Sheets("Sheet2").Cells(Rows.Count, "B").End(xlUp).Offset(1, 0) = pkg.Offset(0, -2)
                Sheets("Sheet2").Cells(Rows.Count, "C").End(xlUp).Offset(1, 0) = pkg.Offset(0, -1)
                Sheets("Sheet2").Cells(Rows.Count, "D").End(xlUp).Offset(1, 0) = "COMEX"
            ElseIf splitPkg(i) Like "*NYMEX*" Then
                Sheets("Sheet2").Cells(Rows.Count, "A").End(xlUp).Offset(1, 0) = pkg.Offset(0, -3)
                Sheets("Sheet2").Cells(Rows.Count, "B").End(xlUp).Offset(1, 0) = pkg.Offset(0, -2)
                Sheets("Sheet2").Cells(Rows.Count, "C").End(xlUp).Offset(1, 0) = pkg.Offset(0, -1)
                Sheets("Sheet2").Cells(Rows.Count, "D").End(xlUp).Offset(1, 0) = "NYMEX"
            ElseIf splitPkg(i) Like "*CME*" Then
                Sheets("Sheet2").Cells(Rows.Count, "A").End(xlUp).Offset(1, 0) = pkg.Offset(0, -3)
                Sheets("Sheet2").Cells(Rows.Count, "B").End(xlUp).Offset(1, 0) = pkg.Offset(0, -2)
                Sheets("Sheet2").Cells(Rows.Count, "C").End(xlUp).Offset(1, 0) = pkg.Offset(0, -1)
                Sheets("Sheet2").Cells(Rows.Count, "D").End(xlUp).Offset(1, 0) = "CME"
            End If
        Next i
    Next pkg
    Application.ScreenUpdating = True
End Sub

 

[Rick Rothstein]

My apologies there is indeed a space between "DEL" and "COMEX" .

Another question... is there a blank row between your data (you example looks like there is a blank cell between each Package cell)?

 

[nt_beans]

Another question... is there a blank row between your data (you example looks like there is a blank cell between each Package cell)?

hi..no blank rows or cell in the spreadsheet...

thanks

 

[nt_beans]

Mumps..thanks a lot..it does the jon quite well...appreciate your help

 

[Rick Rothstein]

Here is another macro that you can consider...

[table="width: 500"]
[tr]
	[td]Sub ReformatDataLayout()
  Dim R As Long, X As Long, PackageCount As Long, Package As Variant, Data As Variant, Result As Variant
  PackageCount = Evaluate("SUM((LEN(D1:D4)-LEN(SUBSTITUTE(SUBSTITUTE(D1:D4,CHAR(160),"" ""),{""CME"",""NYMEX"",""CBOT"",""COMEX""},"""")))/{3,5,4,5})")
  Data = Range("A1").CurrentRegion
  ReDim Result(1 To PackageCount, 1 To 4)
  For R = 2 To UBound(Data)
    For Each Package In Array("CME", "CBOT", "COMEX", "NYMEX")
      If InStr(Data(R, 4), Package) Then
        X = X + 1
        Result(X, 1) = Data(R, 1)
        Result(X, 2) = Data(R, 2)
        Result(X, 3) = Data(R, 3)
        Result(X, 4) = Package
      End If
    Next
  Next
  Sheets("Sheet2").Range("A1:D1").Value = Range("A1:D1").Value
  Sheets("Sheet2").Range("A2").Resize(UBound(Result), 4) = Result
End Sub[/td]
[/tr]
[/table]

 

[nt_beans]

Here is another macro that you can consider...

[TABLE="width: 500"]
<tbody>[TR]
[TD]Sub ReformatDataLayout()
  Dim R As Long, X As Long, PackageCount As Long, Package As Variant, Data As Variant, Result As Variant
  PackageCount = Evaluate("SUM((LEN(D1:D4)-LEN(SUBSTITUTE(SUBSTITUTE(D1:D4,CHAR(160),"" ""),{""CME"",""NYMEX"",""CBOT"",""COMEX""},"""")))/{3,5,4,5})")
  Data = Range("A1").CurrentRegion
  ReDim Result(1 To PackageCount, 1 To 4)
  For R = 2 To UBound(Data)
    For Each Package In Array("CME", "CBOT", "COMEX", "NYMEX")
      If InStr(Data(R, 4), Package) Then
        X = X + 1
        Result(X, 1) = Data(R, 1)
        Result(X, 2) = Data(R, 2)
        Result(X, 3) = Data(R, 3)
        Result(X, 4) = Package
      End If
    Next
  Next
  Sheets("Sheet2").Range("A1:D1").Value = Range("A1:D1").Value
  Sheets("Sheet2").Range("A2").Resize(UBound(Result), 4) = Result
End Sub[/TD]
[/TR]
</tbody>[/TABLE]

Many thanks Rick...it works...appreciate all your help

 

[mumps]

Glad to help.