Solved

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

Posted on 2010-09-10
4
319 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
[X]
Welcome to Experts Exchange

Add your voice to the tech community where 5M+ people just like you are talking about what matters.

  • Help others & share knowledge
  • Earn cash & points
  • Learn & ask questions
  • 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

Free Tool: IP Lookup

Get more info about an IP address or domain name, such as organization, abuse contacts and geolocation.

One of a set of tools we are providing to everyone as a way of saying thank you for being a part of the community.

Question has a verified solution.

If you are experiencing a similar issue, please ask a related question

This article descibes how to create a connection between Excel and SAP and how to move data from Excel to SAP or the other way around.
If you need to forecast numbers -- typically for finance -- the Windows and Mac versions of Excel 2016 have a basket of tools to get the job done.
This Micro Tutorial will demonstrate how to use longer labels with horizontal bar charts instead of the vertical column chart.
This Micro Tutorial demonstrates in Microsoft Excel how to consolidate your marketing data by creating an interactive charts using form controls. This creates cool drop-downs for viewers of your chart to choose from.

626 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