Solved

Based on the value in AF, delete some of the contents of H

Posted on 2010-09-10
4
305 Views
Last Modified: 2012-05-10
Good Afternoon

I am looking to ensure that the contents of column AF, which can have mulitple values, pulled from a sharepoint site, only has the value associated with the value in column H. I like this to work through all of the rows in the spreadsheet.

Example

H contains: Apple
AF contains: Apple=2, Orange=3

I would like to end up with AF containing: Apple=2

Many thanks
0
Comment
Question by:Washcare
  • 2
  • 2
4 Comments
 
LVL 13

Expert Comment

by:MWGainesJR
ID: 33646410
if there will always be a space seperating the values, use the following sub (functions are credited and most are needed by the sub):

'String Functions Library

'This library contains various VBA functions for often-used string handling needs

'Usage note: All string comparisons use binary comparison, i.e. "A" <> "a"

'Copyright 2000 Roman Koch (roman@romankoch.ch)

'http://www.romankoch.ch/capslock/strfun.htm



Public Const Blank As String = " "

Sub get_relative_value()

Dim c As Range

Dim num As Long



For Each c In ActiveSheet.Range("A1:A" & ActiveSheet.Range("A" & ActiveSheet.Range("A:A").Rows.Count).End(xlUp).Row)

    num = SF_countWords(c.Offset(0, 1).Value)

    

    For i = 1 To num

        If InStr(1, SF_getWord(c.Offset(0, 1).Value, i), c.Value) Then

            c.Offset(0, 1).Value = SF_getWord(c.Offset(0, 1).Value, i)

            GoTo nxt

        End If

    Next

nxt:

Next

    



End Sub



Function SF_count(ByVal Haystack As String, ByVal Needle As String) As Long

'count the number of occurences of needle in haystack

'SF_count(" This is my string ","i") returns 3

Dim i As Long, j As Long

If SF_isNothing(Needle) Then

SF_count = 0

Else

i = InStr(1, Haystack, Needle, vbBinaryCompare)

If i = 0 Then

SF_count = 0

Else

i = 0

For j = 1 To Len(Haystack)

If Mid(Haystack, j, Len(Needle)) = Needle Then i = i + 1

Next j

SF_count = i

End If

End If

End Function



Function SF_countWords(ByVal Haystack As String) As Long

'count number of words in a string

'if the string is empty, 0 is returned

'SF_countWords(" This is my string ") returns 4

Dim strChar As String

Dim lngCount As Long, i As Long

Haystack = SF_unSpace(Haystack)

If SF_isNothing(Haystack) Then

SF_countWords = 0

Else

lngCount = 1

For i = 1 To Len(Haystack)

strChar = Mid(Haystack, i, 1)

If strChar = Blank Then

lngCount = lngCount + 1

End If

Next i

SF_countWords = lngCount

End If

End Function



Function SF_getWord(ByVal Haystack As String, ByVal WordNumber As Long) As String

'return nth word of a string

'if the string is empty, a zero-length string is returned

'if there is only one word, the initial string is returned

'if wordnumber is 0 or negative, a zero-length string is returned

'if wordnumber is larger than the number of words in the string, a zero-length string is returned

'SF_getWord(" This is my string ",2) returns "is"

Dim i, lngWords As Long

Haystack = SF_unSpace(Haystack)

If SF_isNothing(Haystack) Then

SF_getWord = Haystack

Else

If WordNumber > 0 Then

lngWords = SF_countWords(Haystack)

If WordNumber > lngWords Then

Haystack = ""

Else

If lngWords > 1 Then

'cut words at the left

For i = 1 To WordNumber - 1

Haystack = Mid(Haystack, InStr(Haystack, Blank) + 1)

Next i

'cut words at the right, if any

i = InStr(Haystack, Blank)

If i > 0 Then Haystack = Left(Haystack, i - 1)

End If

End If

Else

Haystack = ""

End If

SF_getWord = Haystack

End If

End Function



Function SF_InstrRev(ByVal Haystack As String, ByVal Needle As String) As Long

'find the last occurence of needle in haystack (the VB instr function finds the first occurence)

'SF_InstrRev(" This is my string ","i") = 20

Dim i As Long, j As Long

i = InStr(1, Haystack, Needle, vbBinaryCompare)

If SF_isNothing(Needle) Then

SF_InstrRev = 0

Else

If i = 0 Then

SF_InstrRev = 0

Else

If StrComp(Needle, Haystack, vbBinaryCompare) = 0 Then

SF_InstrRev = 1

Else

For j = Len(Haystack) To 1 Step -1

i = InStr(j, Haystack, Needle, vbBinaryCompare)

If i > 0 Then

SF_InstrRev = i

Exit Function

End If

Next j

End If

End If

End If

End Function



Function SF_isNothing(ByVal Haystack As String) As Boolean

'check if there is anything in a string (to avoid testing for

'isnull, isempty, and zero-length strings)

'SF_isNothing(" This is my string ") returns False

If Haystack & "" = "" Then

SF_isNothing = True

Else

SF_isNothing = False

End If

End Function



Function SF_remove(ByVal Haystack As String, ByVal Needle As String) As String

'remove first occurence of needle in haystack

'if needle is empty or not found, haystack is returned

'if needle is equal to haystack, a zero-length string is returned

'SF_remove(" This is my string "," This is m") returns "y string "

Dim i As Long

If SF_isNothing(Needle) Then

SF_remove = Haystack

Else

i = InStr(1, Haystack, Needle, vbBinaryCompare)

If i = 0 Then

SF_remove = Haystack

Else

SF_remove = SF_splitLeft(Haystack, Needle) & SF_splitRight(Haystack, Needle)

End If

End If

End Function



Function SF_removeRev(ByVal Haystack As String, ByVal Needle As String) As String

'remove last occurence of needle in haystack

'if needle is empty or not found, haystack is returned

'if needle is equal to haystack, a zero-length string is returned

'SF_removeRev(" This is my string ","i") returns " This is my strng "

Dim i As Long

If SF_isNothing(Needle) Then

SF_removeRev = Haystack

Else

i = SF_InstrRev(Haystack, Needle)

If i = 0 Then

SF_removeRev = Haystack

Else

SF_removeRev = Left(Haystack, i - 1) & Mid(Haystack, i + Len(Needle))

End If

End If



End Function



Function SF_removeAllOnce(ByVal Haystack As String, ByVal Needle As String) As String

'remove all occurrences of needle in haystack exactly once

'if needle is empty or not found, haystack is returned

'if needle is equal to haystack, a zero-length string is returned

'SF_removeAllOnce("1122a1122","12") returns "12a12"

Dim i As Long

If SF_isNothing(Needle) Then

SF_removeAllOnce = Haystack

Else

i = InStr(1, Haystack, Needle, vbBinaryCompare)

Do While i > 0

Haystack = Left(Haystack, i - 1) & Mid(Haystack, i + Len(Needle))

i = InStr(i, Haystack, Needle, vbBinaryCompare)

Loop

SF_removeAllOnce = Haystack

End If

End Function



Function SF_removeAll(ByVal Haystack As String, ByVal Needle As String) As String

'remove all occurrences of needle in haystack, even those created during removal

'if needle is empty or not found, haystack is returned

'if needle is equal to haystack, a zero-length string is returned

'SF_removeAll("1122a1122","12") returns "a"

Do While InStr(1, Haystack, Needle) > 0

Haystack = SF_removeAllOnce(Haystack, Needle)

Loop

SF_removeAll = Haystack

End Function



Function SF_replace(ByVal Haystack As String, ByVal Needle As String, ByVal NewNeedle As String) As String

'replace first occurence of needle in haystack with newneedle

'if needle is empty or not found, haystack is returned

'if needle is equal to haystack, newneedle is returned

'if needle is equal to newneedle, haystack is returned

'SF_replace(" This is my string ","my","your") returns " This is your string "

Dim i As Long

If SF_isNothing(Needle) Then

SF_replace = Haystack

Else

If StrComp(Needle, NewNeedle, vbBinaryCompare) = 0 Then

SF_replace = Haystack

Else

i = InStr(1, Haystack, Needle, vbBinaryCompare)

If i = 0 Then

SF_replace = Haystack

Else

SF_replace = SF_splitLeft(Haystack, Needle) & NewNeedle & SF_splitRight(Haystack, Needle)

End If

End If

End If

End Function



Function sf_replaceRev(ByVal Haystack As String, ByVal Needle As String, ByVal NewNeedle As String) As String

'replace last occurence of needle in haystack with newneedle

'if needle is empty or not found, haystack is returned

'if needle is equal to haystack, newneedle is returned

'if needle is equal to newneedle, haystack is returned

'SF_replaceRev(" This is my string ","i","o") returns " This is my strong "

Dim i As Long

If SF_isNothing(Needle) Then

sf_replaceRev = Haystack

Else

If StrComp(Needle, NewNeedle, vbBinaryCompare) = 0 Then

sf_replaceRev = Haystack

Else

i = SF_InstrRev(Haystack, Needle)

If i = 0 Then

sf_replaceRev = Haystack

Else

sf_replaceRev = Left(Haystack, i - 1) & NewNeedle & Mid(Haystack, i + Len(Needle))

End If

End If

End If

End Function



Function SF_replaceAllOnce(ByVal Haystack As String, ByVal Needle As String, ByVal NewNeedle As String) As String

'replace all occurrences of needle in haystack with newneedle exactly once

'if needle is empty or not found, haystack is returned

'if needle is equal to newneedle, haystack is returned

'if needle is equal to haystack, newneedle is returned

'SF_replaceAllOnce(" This is my string ","i","ee") returns " Thees ees my streeng "

Dim i As Long

If SF_isNothing(Needle) Then

SF_replaceAllOnce = Haystack

Else

If StrComp(Needle, NewNeedle, vbBinaryCompare) = 0 Then

SF_replaceAllOnce = Haystack

Else

i = InStr(1, Haystack, Needle, vbBinaryCompare)

Do While i > 0

Haystack = Left(Haystack, i - 1) & NewNeedle & Mid(Haystack, i + Len(Needle))

i = i + Len(NewNeedle)

i = InStr(i, Haystack, Needle, vbBinaryCompare)

Loop

SF_replaceAllOnce = Haystack

End If

End If

End Function



Function SF_replaceAll(ByVal Haystack As String, ByVal Needle As String, ByVal NewNeedle As String) As String

'replace all occurrences of needle in haystack with newneedle, even those created during replacing

'if needle is empty or not found, haystack is returned

'if needle is equal to newneedle, haystack is returned

'if needle is equal to haystack, newneedle is returned

'if needle is a subset of newneedle, the function would loop;

'to avoid this, SF_replaceAllOnce is executed instead

'SF_replaceAll(" This is my string ","i","ee") returns " Thees ees my streeng "

If InStr(1, NewNeedle, Needle, vbBinaryCompare) > 0 Then

Haystack = SF_replaceAllOnce(Haystack, Needle, NewNeedle)

Else

Do While InStr(1, Haystack, Needle, vbBinaryCompare) > 0

Haystack = SF_replaceAllOnce(Haystack, Needle, NewNeedle)

Loop

End If

SF_replaceAll = Haystack

End Function



Function SF_splitLeft(ByVal Haystack As String, ByVal Needle As String) As String

'return left part of haystack delimited by the first occurrence of needle

'if needle is empty or not found, haystack is returned

'if haystack starts with needle (or is equal to needle), a zero-length string is returned

'SF_splitLeft(" This is my string ","s is") returns " Thi"

Dim i As Long

If SF_isNothing(Needle) Then

SF_splitLeft = Haystack

Else

i = InStr(1, Haystack, Needle, vbBinaryCompare)

If i = 0 Then

SF_splitLeft = Haystack

Else

SF_splitLeft = Left(Haystack, i - 1)

End If

End If

End Function



Function SF_splitRight(ByVal Haystack As String, ByVal Needle As String) As String

'return right part of haystack delimited by the first occurrence of needle

'if needle is empty or not found, haystack is returned

'if haystack ends with needle (or is equal to needle), a zero-length string is returned

'SF_splitRight(" This is my string "," my s") returns "tring "

Dim i As Long

If SF_isNothing(Needle) Then

SF_splitRight = Haystack

Else

i = InStr(1, Haystack, Needle, vbBinaryCompare)

If i = 0 Then

SF_splitRight = Haystack

Else

SF_splitRight = Mid(Haystack, i + Len(Needle))

End If

End If

End Function



Function SF_unSpace(ByVal Haystack As String) As String

'remove duplicate blanks in a string

'SF_unspace(" This is my string ") returns "This is my string"

If SF_isNothing(Haystack) Then

SF_unSpace = Haystack

Else

Haystack = Trim(Haystack)

Do While InStr(Haystack, Blank & Blank) > 0

Haystack = SF_replaceAllOnce(Haystack, Blank & Blank, Blank)

Loop

SF_unSpace = Haystack

End If

End Function



Function SF_RemoveNonPrt(ByVal Haystack As String) As String

Dim i As Integer

'remove non printable characters, ASCII 0-31 and 127-255 (decimal).

'Copyright (C) Mark Kiehl, 2007.

If SF_isNothing(Haystack) Then

SF_RemoveNonPrt = Haystack

Else

For i = 0 To 31

Haystack = SF_removeAllOnce(Haystack, String$(1, Chr(i)))

Next i

For i = 127 To 255

Haystack = SF_removeAllOnce(Haystack, String$(1, Chr(i)))

Next i

SF_RemoveNonPrt = Haystack

End If

End Function



Function SF_AddRandomNonPrt(ByVal Haystack As String) As String

Dim i As Integer, iLeft As Integer, iRight As Integer, iRnd As Integer

'Add non printable characters, ASCII 0-31 and 127-255 (decimal) at random.

'Copyright (C) Mark Kiehl, 2007.

If SF_isNothing(Haystack) Then

SF_AddRandomNonPrt = Haystack

Else

iLeft = Len(Haystack) / 2

iRight = Len(Haystack) - iLeft

'Int((upperbound - lowerbound + 1) * Rnd + lowerbound)

iRnd = Int((31 - 1 + 1) * Rnd + 1) ' Generate random value between 1 and 31.

Haystack = Left(Haystack, iLeft) & String$(1, Chr(iRnd)) & Right(Haystack, iRight)

iRnd = Int((255 - 127 + 1) * Rnd + 127) ' Generate random value between 127 and 255.

Haystack = Haystack & String$(1, Chr(iRnd))

SF_AddRandomNonPrt = Haystack

End If

End Function

Open in new window

0
 

Author Comment

by:Washcare
ID: 33646500
Wow

Do I need to change any of this to look at my specific columns? I have put this into a module, what is the correct way to use this?

Many thanks
0
 
LVL 13

Accepted Solution

by:
MWGainesJR earned 500 total points
ID: 33646627
I edited it for your columns and took out functions that you don't need. Just put it in a module and run the sub......back up your data first
'String Functions Library

'This library contains various VBA functions for often-used string handling needs

'Usage note: All string comparisons use binary comparison, i.e. "A" <> "a"

'Copyright 2000 Roman Koch (roman@romankoch.ch)

'http://www.romankoch.ch/capslock/strfun.htm



Public Const Blank As String = " "

Sub get_relative_value()

Dim c As Range

Dim num As Long

Dim ws As Worksheet

Set ws = ActiveSheet

For Each c In ws.Range("H1:H" & ws.Range("H" & ws.Range("H:H").Rows.Count).End(xlUp).Row)

    num = SF_countWords(ws.Range("AF" & c.Row).Value)

    

    For i = 1 To num

        If InStr(1, SF_getWord(ws.Range("AF" & c.Row).Value, i), c.Value) Then

            ws.Range("AF" & c.Row).Value = Replace(SF_getWord(ws.Range("AF" & c.Row).Value, i), ",", "")

            GoTo nxt

        End If

    Next

nxt:

Next

    



End Sub



Function SF_countWords(ByVal Haystack As String) As Long

'count number of words in a string

'if the string is empty, 0 is returned

'SF_countWords(" This is my string ") returns 4

Dim strChar As String

Dim lngCount As Long, i As Long

Haystack = SF_unSpace(Haystack)

If SF_isNothing(Haystack) Then

SF_countWords = 0

Else

lngCount = 1

For i = 1 To Len(Haystack)

strChar = Mid(Haystack, i, 1)

If strChar = Blank Then

lngCount = lngCount + 1

End If

Next i

SF_countWords = lngCount

End If

End Function



Function SF_getWord(ByVal Haystack As String, ByVal WordNumber As Long) As String

'return nth word of a string

'if the string is empty, a zero-length string is returned

'if there is only one word, the initial string is returned

'if wordnumber is 0 or negative, a zero-length string is returned

'if wordnumber is larger than the number of words in the string, a zero-length string is returned

'SF_getWord(" This is my string ",2) returns "is"

Dim i, lngWords As Long

Haystack = SF_unSpace(Haystack)

If SF_isNothing(Haystack) Then

SF_getWord = Haystack

Else

If WordNumber > 0 Then

lngWords = SF_countWords(Haystack)

If WordNumber > lngWords Then

Haystack = ""

Else

If lngWords > 1 Then

'cut words at the left

For i = 1 To WordNumber - 1

Haystack = Mid(Haystack, InStr(Haystack, Blank) + 1)

Next i

'cut words at the right, if any

i = InStr(Haystack, Blank)

If i > 0 Then Haystack = Left(Haystack, i - 1)

End If

End If

Else

Haystack = ""

End If

SF_getWord = Haystack

End If

End Function





Function SF_isNothing(ByVal Haystack As String) As Boolean

'check if there is anything in a string (to avoid testing for

'isnull, isempty, and zero-length strings)

'SF_isNothing(" This is my string ") returns False

If Haystack & "" = "" Then

SF_isNothing = True

Else

SF_isNothing = False

End If

End Function

'



'

Function SF_replaceAllOnce(ByVal Haystack As String, ByVal Needle As String, ByVal NewNeedle As String) As String

'replace all occurrences of needle in haystack with newneedle exactly once

'if needle is empty or not found, haystack is returned

'if needle is equal to newneedle, haystack is returned

'if needle is equal to haystack, newneedle is returned

'SF_replaceAllOnce(" This is my string ","i","ee") returns " Thees ees my streeng "

Dim i As Long

If SF_isNothing(Needle) Then

SF_replaceAllOnce = Haystack

Else

If StrComp(Needle, NewNeedle, vbBinaryCompare) = 0 Then

SF_replaceAllOnce = Haystack

Else

i = InStr(1, Haystack, Needle, vbBinaryCompare)

Do While i > 0

Haystack = Left(Haystack, i - 1) & NewNeedle & Mid(Haystack, i + Len(Needle))

i = i + Len(NewNeedle)

i = InStr(i, Haystack, Needle, vbBinaryCompare)

Loop

SF_replaceAllOnce = Haystack

End If

End If

End Function

'



'

Function SF_unSpace(ByVal Haystack As String) As String

'remove duplicate blanks in a string

'SF_unspace(" This is my string ") returns "This is my string"

If SF_isNothing(Haystack) Then

SF_unSpace = Haystack

Else

Haystack = Trim(Haystack)

Do While InStr(Haystack, Blank & Blank) > 0

Haystack = SF_replaceAllOnce(Haystack, Blank & Blank, Blank)

Loop

SF_unSpace = Haystack

End If

End Function

'

Open in new window

0
 

Author Closing Comment

by:Washcare
ID: 33646686
Many thanks, I understand know where the code need to be modified.

Thank you
0

Featured Post

What Security Threats Are You Missing?

Enhance your security with threat intelligence from the web. Get trending threat insights on hackers, exploits, and suspicious IP addresses delivered to your inbox with our free Cyber Daily.

Join & Write a Comment

Introduction This Article is a follow-up to my Mappit! Addin Article (http://www.experts-exchange.com/A_2613.html), it was inspired by an email posting I made to EUSPRIG (http://www.eusprig.org/index.htm), I will briefly cover: 1) An overvie…
This code takes an Excel list of URL’s and adds a header titled “URL List”. It then searches through all URL’s in column “A”, looking for duplicates. When a duplicate is found, it is moved to the top of the list. The duplicate URL’s are then highlig…
The viewer will learn how to simulate a series of sales calls dependent on a single skill level and learn how to simulate a series of sales calls dependent on two skill levels. Simulating Independent Sales Calls: Enter .75 into cell C2 – “skill leve…
This Micro Tutorial will demonstrate on a Mac how to change the sort order for chart legend values and decrpyt the intimidating chart menu.

743 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

10 Experts available now in Live!

Get 1:1 Help Now