Extract Remaining text from cells

How How · Dec 21st 2017

Hi, I'm looking for help with extracting a single letter from cells, Col B2 (B1 & C1 are headers). In the example below the extracted data is in column C and is taken from every cell in column B that has a letter "D" in that range. (Can be left or right of letter D), the actual search letter will come from another cell (H2). Note there are no blanks in the extracted data (Col C). I have tried over a week to no avail. Thanks in advance.
[TABLE="border: 2, cellpadding: 1, width: 100"]

[tr]

[td]

Col B

[/td]

[td]

Col C

[/td]

[/tr]

[tr]

[td]

AD

[/td]

[td]

A

[/td]

[/tr]

[tr]

[td]

FG

[/td]

[td]

F

[/td]

[/tr]

[tr]

[td]

RT

[/td]

[td]

S

[/td]

[/tr]

[tr]

[td]

DF

[/td]

[td][/td]

[/tr]

[tr]

[td]

ER

[/td]

[td][/td]

[/tr]

[tr]

[td]

SD

[/td]

[td][/td]

[/tr]

[tr]

[td]

AE

[/td]

[td][/td]

[/tr]

[/TABLE]

**Trebor76** · Dec 22nd 2017

Hi there,

As long as there's only two letters in each cell down column B this will do the job:

Code

Option Explicit
Option Compare Text 'Ignore case sensitivity
Sub Macro1()


    Application.ScreenUpdating = False


    Dim rngMyCell As Range


    For Each rngMyCell In Range("B2:B" & Range("B" & Rows.Count).End(xlUp).Row)  'Works from cell B2 down. Change to suit if necessary.
        If Left(rngMyCell, 1) = Range("H2") Then 'Entry in cell H2 is not case sensitive. Refer above.
            Range("C" & Rows.Count).End(xlUp).Offset(1, 0).Value = Right(rngMyCell, 1)
        ElseIf Right(rngMyCell, 1) = Range("H2") Then 'Entry in cell H2 is not case sensitive. Refer above.
            Range("C" & Rows.Count).End(xlUp).Offset(1, 0).Value = Left(rngMyCell, 1)
        End If
    Next rngMyCell


    Application.ScreenUpdating = True


End Sub

Display More

Just make sure you run the code while on the sheet with the data.

Regards,

Robert

How How · Dec 22nd 2017

Works Perfetctly!! I noticed there were random "spaces" between the 2 letters in my column but the code still worked...... Thanks very much!! :congrats:

I Know I didnt specify in the original post (Didnt think of it till now).... Would it be possible to do the same but with mulitple columns... ie Letter A in col H2, Letter "B" in col I2, Letter "C" in Col then the all fill out with thier pairing letter. No problems if it cant be done easy...... I can just use a seperate code for each letter. Thanks again

jolivanes · Dec 22nd 2017

Another possibilty maybe

Code

Sub AAAAA()
Dim c As Range
    For Each c In Range("B2:B" & Cells(Rows.Count, 2).End(xlUp).Row)
        If Len(c.Value) - Len(Replace(c.Value, [H1], "")) = 1 Then c.Offset(, 1).Value = Replace(c.Value, [H1], "")
    Next c
End Sub

If capitalization comes into play, use

Code

Option Compare Text

at the top

**Trebor76** · Dec 22nd 2017

Hi How How,

Glad we're on the right track. Here's my codes adapted to work for what's in cells H2, I2 and J2:

Code

Option Explicit
Option Compare Text 'Ignore case sensitivity
Sub Macro1()


    Application.ScreenUpdating = False


    Dim rngMyCell As Range


    For Each rngMyCell In Range("B2:B" & Range("B" & Rows.Count).End(xlUp).Row)  'Works from cell B2 down. Change to suit if necessary.
        If Left(rngMyCell, 1) = Range("H2") Or Left(rngMyCell, 1) = Range("I2") Or Left(rngMyCell, 1) = Range("J2") Then 'Entries in cells H2, I2 and J2 are not case sensitive. Refer above.
            Range("C" & Rows.Count).End(xlUp).Offset(1, 0).Value = Right(rngMyCell, 1)
        ElseIf Right(rngMyCell, 1) = Range("H2") Or Right(rngMyCell, 1) = Range("I2") Or Right(rngMyCell, 1) = Range("J2") Then 'Entries in cells H2, I2 and J2 are not case sensitive. Refer above.
            Range("C" & Rows.Count).End(xlUp).Offset(1, 0).Value = Left(rngMyCell, 1)
        End If
    Next rngMyCell


    Application.ScreenUpdating = True


End Sub

Display More

HTH

Robert

jolivanes · Dec 22nd 2017

Code

Sub AAAAA_3_Columns()
Dim c As Range, i As Long
    For Each c In Range("B2:B" & Cells(Rows.Count, 2).End(xlUp).Row)
        For i = 8 To 10    '<----- assuming letters are in columns H, I and J
            If Len(c.Value) - Len(Replace(c.Value, Cells(1, i).Value, "")) = 1 Then c.Offset(, 1).Value = Replace(c.Value, Cells(1, i).Value, "")
        Next i
    Next c
    ActiveSheet.UsedRange.Columns(3).SpecialCells(4).Delete Shift:=xlUp
End Sub

To the both of you, a Merry Christmas and a Happy and Prosperous New Year.

**Trebor76** · Dec 23rd 2017

Quote

To the both of you, a Merry Christmas and a Happy and Prosperous New Year.

How nice :thumbcoo: And best wishes to you jolivanes :smile:

How How · Dec 24th 2017

Excellent stuff guys..... And yes a very merry x-mas and an even happier NEWYEAR to you all :wowee::cheers:

How How · Dec 24th 2017

Trebor76... I have done what I was requiring by doing as below (Many times)... So that All letter "A" pairs will be in Col H, all letter "B" pairs will be in Col I and so on...... Working perfectly this way, just wondered if there was a shorter code to do the same...... No probs if cant be done easily.

Code

For Each rngMyCell In Range("B2:B" & Range("B" & Rows.Count).End(xlUp).Row)  'Works from cell B2 down. Change to suit if necessary.




    '**********************************************************************************************************************************


        If Left(rngMyCell, 1) = Range("H1") Then  'Entry in cell H1 is not case sensitive. Refer above.
            Range("H" & Rows.Count).End(xlUp).Offset(1, 0).Value = Right(rngMyCell, 1)




        ElseIf Right(rngMyCell, 1) = Range("H1") Then
            Range("H" & Rows.Count).End(xlUp).Offset(1, 0).Value = Left(rngMyCell, 1)


           End If


     '**********************************************************************************************************************************




  If Left(rngMyCell, 1) = Range("I1") Then
            Range("I" & Rows.Count).End(xlUp).Offset(1, 0).Value = Right(rngMyCell, 1)




        ElseIf Right(rngMyCell, 1) = Range("I1") Then
            Range("I" & Rows.Count).End(xlUp).Offset(1, 0).Value = Left(rngMyCell, 1)




            End If


     '**************************************************************************************************************************

Display More

jolivanes · Dec 24th 2017

Re: just wondered if there was a shorter code to do the same
Maybe I am missing something but why is that important?

How big is the range you're working with? Have you put a timer on both codes to see how long each takes on your actual workbook?

jolivanes · Dec 24th 2017

Here is a shorter (amount of lines) code.
The time difference between Trebor76's code and this code on 4700 entries is 0.08 seconds in favor of this code on my machine.

Code

Sub How_How_2()
Dim c As Range, i As Long
    Application.ScreenUpdating = False
    For Each c In Range("B2:B" & Cells(Rows.Count, 2).End(xlUp).Row)    '<----- 4700 entries
        For i = 8 To 10
            If Len(c.Value) - Len(Replace(c.Value, Cells(1, i).Value, "")) = 1 Then Cells(Rows.Count, c.Offset(, 1).Column).End(xlUp).Offset(1).Value = Replace(c.Value, Cells(1, i).Value, "")
        Next i
    Next c
    Application.ScreenUpdating = True
End Sub

How How · Dec 25th 2017

Jolivanes, Merry XMas...... Your code is putting everything in col C (Originally asked for)..... See the picture below, all letter "A" pairing will now start in "H2", Letter "B" pairing will start in "I2" and so on. I needed to copy Trebor76 code 17 times changing the col & letter each time... Works fine, I was just wondering if this could be shortened.
P.s The numbers on row 20 are for Byes to be applied in case of odd numbers (The numbers will have to be manually inputted and will be variable).
[ATTACH=JSON]{"data-align":"none","data-size":"full","title":"Example.JPG","caption":"Caption","data-attachmentid":1197326}[/ATTACH]

jolivanes · Dec 25th 2017

Re: I needed to copy Trebor76 code 17 times
Our alphabet has 26 letters, not 17
Start from scratch explaining what you have and where you have it and what needs to go from wherever to wherever with the code.
I am not being nasty but the "all letter "A" pairing will now start in "H2", Letter "B" pairing will start in "I2" and so on" indicates to me A to Z but the "17 times" quashes that idea.
It looks to me like you want the remaining letter under the letter that you discard.
If you work on Column H (the letter A), Cell H2 would have an "L", Cell H3 a "J" and Cell H4 an "H".
For Column I (the letter B) it would be a "K", "I" and a "G"
Is that right?
A Merry Christmas and a Happy and Prosperous New Year to you and yours.

jolivanes · Dec 25th 2017

If the scenario in the previous post is right, this might do what you want (try it on a copy of your wb).

Code

Sub AAAAA_26_Columns()
Dim c As Range, Msg1 As String, i As Long, t
    t = Timer
    Application.ScreenUpdating = False
    For Each c In Range("B2:B" & Cells(Rows.Count, 2).End(xlUp).Row)
        For i = 8 To 33
            If Len(c.Value) - Len(Replace(c.Value, Cells(1, i).Value, "")) = 1 Then Cells(Rows.Count, i).End(xlUp).Offset(1).Value = Replace(c.Value, Cells(1, i).Value, "")
        Next i
    Next c
    Application.ScreenUpdating = True
    MsgBox "This macro took " & Format(Round(Timer - t, 2), "00:00:00.00") & " seconds to run."
End Sub

Display More

**Trebor76** · Dec 25th 2017

As well as jolivanes's nifty code here's my revised attempt which dynamically finds the last column (using Row 1) in the worksheet each time the macro is run:

Code

Option Explicit
Option Compare Text 'Ignore case sensitivity
Sub Macro1()


    Dim rngMyCell  As Range
    Dim lngMyCol   As Long
    Dim lngLastCol As Long


    Application.ScreenUpdating = False


    lngLastCol = Cells(1, Columns.Count).End(xlToLeft).Column 'Finds the last column in Row 1 in the active sheet. Change to suit if necessary.


    For Each rngMyCell In Range("B2:B" & Range("B" & Rows.Count).End(xlUp).Row)  'Works from cell B2 down. Change to suit if necessary.
        'If the last column from Row 1 in the active sheet is less then 8 (i.e. column H), then...
        If lngLastCol < 8 Then
            '... turn screen updating on and exit (quit) the macro
            Application.ScreenUpdating = True
            Exit Sub
        End If
        For lngMyCol = 8 To lngLastCol 'Loops through every column from 8 (column H) to whatever the last column is.
            If Left(rngMyCell, 1) = Cells(1, lngMyCol) Then 'Entry in cell H1 is not case sensitive. Refer above.
                Cells(Rows.Count, lngMyCol).End(xlUp).Offset(1, 0).Value = Right(rngMyCell, 1)
            ElseIf Right(rngMyCell, 1) = Cells(1, lngMyCol) Then
                Cells(Rows.Count, lngMyCol).End(xlUp).Offset(1, 0).Value = Left(rngMyCell, 1)
            End If
        Next lngMyCol
    Next rngMyCell


    Application.ScreenUpdating = True


End Sub

Display More

Robert

How How · Dec 26th 2017

Wow, both codes work as designed and the timings are very similar........ Both much less code than I have just now...... Thank you both very much........ All on X-mas day too....... Great help and hopefully I will learn more from this.

With both codes I had to remove the numbers from row 20 because the data was being put below them, but this is not a hardship as I can move the numbers to another location. (Numbers were for weekly bye's)

I will go and work with this, I will be trying to add a "Bye" in the column where each team will have to have a bye when there is an odd number (Week 1, week 2 etc).... But I will have a go myself & if I do get stuck I will start another thread. Thanks again :rock:

**Trebor76** · Dec 26th 2017

Thanks for letting us know and you're welcome. I'm glad we were able to come up with a workable solution for you

Extract Remaining text from cells

Participate now!

Share