[VBA] Cut down a string to match another string, if applicable

[RockandGrohl]

Hi all,

It was all going so well.

In N12 I have a long string of place names, like this:

Aberystwyth, Accrington, Alfreton, Altrincham, Banbury, Bangor, Barnsley, Barrow-in-Furness, Basingstoke, Bath, Bebington, Bedford, Belper, Beverley, Biggleswade, Birkenhead, Bishop Auckland, Blackburn, Blackpool, Bletchley, Bognor Regis, Bolton, Boston, Bournemouth, Bradford, Bridgend, Bridgnorth, Bridgwater, Bridlington, Bridport, Bristol, Bristol Cribbs Causeway, Bromsgrove, Burnley, Burton-upon-Trent, Bury, Bury St Edmunds, Cambridge, Cannock, Cardiff West Services (M4), Carlisle, Carnforth, Chatteris, Cheltenham, Chester, Chesterfield, Chichester, Chippenham, Chorley, Christchurch, Cinderford, Cirencester, Cleethorpes, Cleveleys, Coalville, Coleford, Colne, Colwyn Bay, Corby, Coventry, Crewe, Dalton-in-Furness, Darlington, Darwen, Daventry, Derby, Dewsbury, Doncaster, Dorchester, Driffield, Dudley, Dunstable, Durham, East Cowes, Eastleigh, Ellesmere Port, Ely, Evesham, Exeter Services (M5), Fareham, Fleetwood, Flint, Gainsborough, Gloucester, Gorleston, Grange-over-Sands, Grantham, Grantham North Services (A1), Great Yarmouth, Grimsby, Halesowen, Halifax, Harrogate, Hartlepool, Havant, Hereford, Hessle, Holbeach, Hucknall, Huddersfield, Hull, Hunstanton, Huntingdon, Ilkeston, Ivybridge, Keighley, Kempston, Kendal, Kettering, Keynsham, Kidderminster, Kidsgrove, King's Lynn, Kingswood, Lancaster, Leamington Spa, Leeds, Leeming Bar Services (A1(M)), Leicester, Leigh, Leominster, Letchworth, Leyland, Lincoln, Littlehampton, Liverpool, Llandudno Junction, Llanelli, Long Eaton, Loughborough, Louth, Lowestoft, Ludlow, Luton, Lydney, Lytham St Annes, Mablethorpe, Malton, Mansfield, March, Market Harborough, Melton Mowbray, Middlesbrough, Middlewich, Milton Keynes, Mold, Morley, Newark, Newcastle-under-Lyme, Newcastle-upon-Tyne, Newmarket, Newport (Isle of Wight), Newport (South Wales), Newton Abbot, North Hykeham, Northallerton, Northampton, Northop, Northwich, Norwich, Nottingham, Oswestry, Oxford, Paignton, Penrith, Peterborough, Peterborough Services (A1(M)), Peterlee, Plymouth, Pontefract, Poole, Portsmouth, Prestatyn, Preston, Queensferry, Reading, Rhyl, Ross-on-Wye, Rotherham, Rugby, Runcorn, Rushden, Ryde, Sale, Sandown, Scarborough, S****horpe, Selby, Shanklin, Sheffield, Shipley, Shrewsbury, Skegness, Solihull, Southampton, Southampton Port, Southport, Spalding, St Helens, Stafford, Stamford, Stevenage, Stockton-on-Tees, Stoke-on-Trent, Stonehouse, Stourbridge, Stroud, Sunderland, Sutton Coldfield, Swadlincote, Swansea, Swindon, Taunton, Telford, Tewkesbury, Thetford, Tiverton Sampford Peverell Services (M5), Torquay, Ulverston, Wakefield, Wallasey, Walsall, Wareham, Warrington, Warrington Lymm Services (M6), Warwick, Waterlooville, Wellingborough, Wellington (Shrops.), Welshpool, Weston-super-Mare, Wetherby Services (A1(M)), Weymouth, Whitby, Whitchurch (Shrops.), Whitley Bay, Widnes, Wigan, Wisbech, Wolverhampton, Woodall Services (M1), Woolley Edge Services (M1), Worcester, Worksop, Worthing, Wrexham, Yate, York

In B3 I have another string of placenames, but these can be 1-5 places long, in this instance it's

Bromsgrove, Worcester

What I need to do is cut down N12, that huge list of places, to be only the list of places in B3. So N12's final output would look like:

Bromsgrove, Worcester

Let's use another example, with that same massive list of places. But this time, B3 has "Worcester, Pershore" as valid places.

Because the string in N12 has Worcester, but not Pershore, it needs to look like this "Worcester"

So the challenge for me is making sure that where there are >1 valid placenames, they are comma separated, but if there's only one valid placename, it appears solo.

I've tried various things like INSTR but I can't crack it, like deleting everything else between the commas where it doesn't match the valid pickups.

Thanks for your help.

 

[Peter_SSs]

Give this a try.

Sub Cut_List()
  Dim d As Object
  Dim vItm As Variant
  Dim sShort As String
  
  Set d = CreateObject("Scripting.Dictionary")
  For Each vItm In Split(Range("N12").Value, ", ")
    d(vItm) = Empty
  Next vItm
  For Each vItm In Split(Range("B3").Value, ", ")
    If d.exists(vItm) Then sShort = sShort & ", " & vItm
  Next vItm
  Range("N12").Value = Mid(sShort, 3)
End Sub

 

[RockandGrohl]

Give this a try.

Sub Cut_List()
  Dim d As Object
  Dim vItm As Variant
  Dim sShort As String
  
  Set d = CreateObject("Scripting.Dictionary")
  For Each vItm In Split(Range("N12").Value, ", ")
    d(vItm) = Empty
  Next vItm
  For Each vItm In Split(Range("B3").Value, ", ")
    If d.exists(vItm) Then sShort = sShort & ", " & vItm
  Next vItm
  Range("N12").Value = Mid(sShort, 3)
End Sub

Yep, that works beautifully. Never come across Scripting.Dictionary - does that compile a list of values (which are in B3) to check against?

Thank you for your time!

 

[Fluff]

How about

Sub RockandGrohl()
   Dim Sp As Variant
   Dim i As Long
   Dim Res As String
   
   Sp = Split(Range("B3"), ", ")
   For i = 0 To UBound(Sp)
      If InStr(1, Range("N12") & ",", Sp(i) & ",", vbTextCompare) > 0 Then
         Res = Res & Sp(i) & ", "
      End If
   Next i
   Range("N12").Value = Left(Res, Len(Res) - 2)
End Sub

I was way too slow

 

[Peter_SSs]

Yep, that works beautifully.

Thank you for your time!

Good news! You're welcome.

Never come across Scripting.Dictionary - does that compile a list of values (which are in B3) to check against?

No, the dictionary compiles a list of the N12 values, then checks the B3 values to see if they are in that big list.

 

[RockandGrohl]

How about

Sub RockandGrohl()
   Dim Sp As Variant
   Dim i As Long
   Dim Res As String
   
   Sp = Split(Range("B3"), ", ")
   For i = 0 To UBound(Sp)
      If InStr(1, Range("N12") & ",", Sp(i) & ",", vbTextCompare) > 0 Then
         Res = Res & Sp(i) & ", "
      End If
   Next i
   Range("N12").Value = Left(Res, Len(Res) - 2)
End Sub

I was way too slow

Yeah, you should be ashamed of yourself :'D hahaha


Perhaps you can fight for runner up trophy, this string:

[TABLE="width: 64"]
<tbody>[TR]
  [TD="width: 64"]Penzance, Camborne,  Redruth, Falmouth, Truro, St Austell, Liskeard, Saltash, Plymouth, Paignton,  Torquay, Newton Abbot, Newquay, Bodmin, Launceston, Exeter Services (M5),  Honiton, Taunton, Bridgwater, Burnham-on-Sea, Weston-super-Mare, Clevedon,  Nailsea, Bideford, Barnstaple, South Molton, Tiverton Sampford Peverell  Services (M5), Lyme Regis, Bridport, Weymouth, Dorchester, Yeovil, Street,  Glastonbury, Wells, Shepton Mallet, Bristol, Yate, Bristol Cribbs Causeway,  Warminster, Frome, Trowbridge, Melksham, Chippenham, Bath, Keynsham,  Kingswood, Llanelli, Swansea, Bridgend, Cardiff, Newport (South Wales),  Cwmbran, Caldicot, Chepstow, Thornbury, Dursley, Lydney, Coleford,  Cinderford, Ross-on-Wye, Newent, Swindon, Cricklade, Cirencester, Stroud,  Stonehouse, Quedgeley, Gloucester, Cheltenham, Bishop's Cleeve, Tewkesbury,  Evesham, Pershore, Hereford, Ledbury, Malvern, Worcester, Droitwich,  Bromsgrove, Redditch, Solihull, Sutton Coldfield, Walsall, Cannock,  Leominster, Ludlow, Bewdley, Kidderminster, Stourbridge, Halesowen, Dudley,  Birmingham, Wolverhampton, Welshpool, Shrewsbury, Wellington (Shrops.),  Telford[/TD]
[/TR]
</tbody>[/TABLE]

Has produced this:

[TABLE="width: 64"]
<tbody>[TR]
  [TD="width: 64"]Redditch, Alcester,  Redditch[/TD]
[/TR]
</tbody>[/TABLE]

From this set of valid pickups:

[TABLE="width: 64"]
<tbody>[TR]
  [TD="width: 64"]Redditch, Alcester[/TD]
[/TR]
</tbody>[/TABLE]

Any ideas? I'll try your function and see what happens.

 

[Fluff]

Bot Peter's code & mine just return "Redditch" for that string

 

[Peter_SSs]

.. this string:

[TABLE="width: 64"]
<tbody>[TR]
  [TD="width: 64"]Penzance, Camborne,  Redruth, Falmouth, Truro, St Austell, Liskeard, Saltash, Plymouth, Paignton,  Torquay, Newton Abbot, Newquay, Bodmin, Launceston, Exeter Services (M5),  Honiton, Taunton, Bridgwater, Burnham-on-Sea, Weston-super-Mare, Clevedon,  Nailsea, Bideford, Barnstaple, South Molton, Tiverton Sampford Peverell  Services (M5), Lyme Regis, Bridport, Weymouth, Dorchester, Yeovil, Street,  Glastonbury, Wells, Shepton Mallet, Bristol, Yate, Bristol Cribbs Causeway,  Warminster, Frome, Trowbridge, Melksham, Chippenham, Bath, Keynsham,  Kingswood, Llanelli, Swansea, Bridgend, Cardiff, Newport (South Wales),  Cwmbran, Caldicot, Chepstow, Thornbury, Dursley, Lydney, Coleford,  Cinderford, Ross-on-Wye, Newent, Swindon, Cricklade, Cirencester, Stroud,  Stonehouse, Quedgeley, Gloucester, Cheltenham, Bishop's Cleeve, Tewkesbury,  Evesham, Pershore, Hereford, Ledbury, Malvern, Worcester, Droitwich,  Bromsgrove, Redditch, Solihull, Sutton Coldfield, Walsall, Cannock,  Leominster, Ludlow, Bewdley, Kidderminster, Stourbridge, Halesowen, Dudley,  Birmingham, Wolverhampton, Welshpool, Shrewsbury, Wellington (Shrops.),  Telford[/TD]
[/TR]
</tbody>[/TABLE]

Has produced this:

[TABLE="width: 64"]
<tbody>[TR]
  [TD="width: 64"]Redditch, Alcester,  Redditch[/TD]
[/TR]
</tbody>[/TABLE]

From this set of valid pickups:

[TABLE="width: 64"]
<tbody>[TR]
  [TD="width: 64"]Redditch, Alcester[/TD]
[/TR]
</tbody>[/TABLE]

I din't get that result with either code, but I was going to post a comment about Fluff's code anyway. With the original long string and
B3 = "Worcester, Cowes, Flint"

It produces all 3 still in the result, even though Cowes is not in the big list. I believe it needs this slight adjustment.

<del>If InStr(1, Range("N12") & ",", Sp(i) & ",", vbTextCompare) > 0 Then</del>
If InStr(1, ", " & Range("N12") & ",", ", " & Sp(i) & ",", vbTextCompare) > 0 Then

 

[RockandGrohl]

How about

Sub RockandGrohl()
   Dim Sp As Variant
   Dim i As Long
   Dim Res As String
   
   Sp = Split(Range("B3"), ", ")
   For i = 0 To UBound(Sp)
      If InStr(1, Range("N12") & ",", Sp(i) & ",", vbTextCompare) > 0 Then
         Res = Res & Sp(i) & ", "
      End If
   Next i
   Range("N12").Value = Left(Res, Len(Res) - 2)
End Sub

I was way too slow

Hmm, yours has the same problem as Peter's. Here's what I've got:

                Dim Sp As Variant                Dim i As Long
                Dim Res As String
                
                Sp = Split(adstemp.Range("B3"), ", ")
                For i = 0 To UBound(Sp)
                   If InStr(1, adstemp.Range("N" & 11 + x) & ",", Sp(i) & ",", vbTextCompare) > 0 Then
                      Res = Res & Sp(i) & ", "
                   End If
                Next i
                adstemp.Range("N" & 11 + x).Value = Left(Res, Len(Res) - 2)
                Cells(ActiveCell.Row, "O").Value = adstemp.Range("N" & 11 + x).Value

So I might have 1, 2 or 3 ads to place in a paper. Let's say I have 2, this is in a for to x loop

The ads are in column H row 12 downwards of Adstemp. The applicable route I have set in column N.

There's an overarching loop that does a huge variety of things, but this is the relevant code included.

It will go to H + 11 + X (in this case, cell H12 as it's the first one of the two to be placed.

It puts in some data, then goes to split the pickups to what is valid.

Here, both of your code works admirably and it successfully whittles down the route to the only two valid pickups, which are Redditch and Alcester. Then we go to x = 2, the 2nd tour to be placed, and we start again from the top.

It now looks at the tour for H + 11 + x (2) to land in cell H13, from here it places the whole route in cell N13, then it compares against cell B3 which is still the same as it was before, sees the valid pickups Redditch and Alcester, then goes to split them up. Except now it gives me "Redditch, Alcester, Redditch"

One thing I have noticed is that if I hover over "Sp(i)" it says "Sp=(i) = <Subscript out of range> - does this have anything to do with it?

Thanks.

 

[Fluff]

If you're running it in a loop you may need to clear the variable Res like

adstemp.Range("N" & 11 + x).Value = Left(Res, Len(Res) - 2)
Res=""
Cells(ActiveCell.Row, "O").Value = adstemp.Range("N" & 11 + x).Value