VBA - Compare 2 columns for partial matches, and return only last 3 characters of matches

[TropicalMagic]

Hi all,

I’m trying to –

1. Compare Column G from Workbook 1, starting from row 2, to only the first 10 characters in Column A, starting from row 9, from Workbook 2 for matching values
2. If there are matching values, copy only the last 3 characters in Column A from Workbook 2 to Column F from Workbook 1

However, the macro is continuously running without ending. I'm not sure if there is any error present.

Here is my code:

Dim Range1 As Range, Range2 As Range, Rng1 As Range, Rng2 As Range
Dim i As Long

Set Range1 = Workbook1.Sheet(1).Range("G9:G" & LASTROW1)
Set Range2 = Workbook2.Sheet(1).Range("A2:A" & LASTROW2)

For i = 9 to LASTROW1
For Each Rng1 in Range1
For Each Rng2 In Range2
If Rng1.Value = Left(Rng2.Value, 10) Then
    Right(Rng2.Value, 3).Copy
    Workbook1.Sheet(1).Range("F" & i).PasteSpecial
End If

Next
Next
Next

Many thanks in advance!

 

[kevin9999]

Could you post your full code, and preferably a sample of your data?

 

[TropicalMagic]

Sure, the full code can be given as:

(I have edited it to align with the sample data layout)

Option Explicit

Sub LAST_3_CHARACTERS()

Application.ScreenUpdating = False
Application.DisplayAlerts = False
Application.AskToUpdateLinks = False

Dim Range1 As Range, Range2 As Range, Rng1 As Range, Rng2 As Range
Dim i As Long

Set Range1 = Workbook1.Sheet(1).Range("G9:G" & LASTROW1)
Set Range2 = Workbook2.Sheet(1).Range("A2:A" & LASTROW2)

For i = 9 to LASTROW1
For Each Rng1 in Range1
For Each Rng2 In Range2
If Rng1.Value = Left(Rng2.Value, 17) Then
    Right(Rng2.Value, 3).Copy
    Workbook2.Sheet(1).Range("G" & i).PasteSpecial
End If

Next
Next
Next

MsgBox "READY!"

Application.ScreenUpdating = True
Application.DisplayAlerts = True
Application.AskToUpdateLinks = True

End Sub

Here is the Mini-sheet for Workbook 1:

TEST.xlsx
	A	B	C	D	E	F	G
1	THIS AREA WILL BE UNUSED
2
3
4
5
6
7
8	UNIQUE LOCATION	ORIGIN LOCATION	ORIGIN COUNTRY	DESTINATION LOCATION	DESTINATION COUNTRY	SERVICE	CREATURE
9	SELKRMEBAULEVEL 1DOG	SEL	KR	MEB	AU	LEVEL 1	DOG
10	SELKRMEBAULEVEL 2PIG	SEL	KR	MEB	AU	LEVEL 2	PIG
11	SHACNLAXUSLEVEL 1PIG	SHA	CN	LAX	US	LEVEL 1	PIG
12	SHACNNYCUSLEVEL 1CAT	SHA	CN	NYC	US	LEVEL 1	CAT
13	SHACNNYCUSLEVEL 1DOG	SHA	CN	NYC	US	LEVEL 1	DOG
14	SHACNCHIUSLEVEL 2PIG	SHA	CN	CHI	US	LEVEL 2	PIG
15	SHACNCHIUSLEVEL 1OWL	SHA	CN	CHI	US	LEVEL 1	OWL
16	KULMYSINSINLEVEL 1PIG	KUL	MY	SIN	SIN	LEVEL 1	PIG
17	KULMYSINSINLEVEL 2PIG	KUL	MY	SIN	SIN	LEVEL 2	PIG
18	KULMYSINSINLEVEL 1DOG	KUL	MY	SIN	SIN	LEVEL 1	DOG
19	KULMYSINSINLEVEL 2DOG	KUL	MY	SIN	SIN	LEVEL 2	DOG
WORKBOOK 1

Cell Formulas
Range	Formula
A9:A19	A9	=B9&C9&D9&E9&F9&G9

Here is the Mini-sheet for Workbook 2:

TEST.xlsx
	A	B	C	D	E	F	G
1	UNIQUE LOCATION	ORIGIN LOCATION	ORIGIN COUNTRY	DESTINATION LOCATION	DESTINATION COUNTRY	SERVICE	CREATURE
2	SELKRMEBAULEVEL 1	SEL	KR	MEB	AU	LEVEL 1
3	SHACNCHIUSLEVEL 2	SHA	CN	CHI	US	LEVEL 2
4	SHACNNYCUSLEVEL 1	SHA	CN	NYC	US	LEVEL 1
5	KULMYSINSINLEVEL 2	KUL	MY	SIN	SIN	LEVEL 2
6	KULMYSINSINLEVEL 1	KUL	MY	SIN	SIN	LEVEL 1
7	KULMYSINSINLEVEL 2	KUL	MY	SIN	SIN	LEVEL 2
WORKBOOK 2

Cell Formulas
Range	Formula
A2:A7	A2	=B2&C2&D2&E2&F2

Many thanks!

 

[kevin9999]

That's not the full code. I don't see a Sub() End Sub. You're using LASTROW1 as a variable, but nowhere in what you posted is that variable set. Could we see the full code please?

 

[kevin9999]

Ignore my last post, & thank you for posting some data, although I still can't see where you set LASTROW1?

 

[DanteAmor]

to only the first 10 characters

Actually there are 17.
------------

In book 1, these 2 data (the 17 characters on the left) are repeated, so if you find the data in book 2, then you put CAT first and then DOG. Finally only "DOG" remains in the cell.
What should be done in those cases, or is it a typo in your example and that's not going to happen.

Workbook1.xlsx
	A
12	SHACNNYCUSLEVEL 1CAT
13	SHACNNYCUSLEVEL 1DOG
1

Cell Formulas
Range	Formula
A12:A13	A12	=B12&C12&D12&E12&F12&G12

-------------

Try the following macro. Set the names of your books in the data highlighted in blue.
Note: the 2 books must be open.

Sub Compare2columns()
  Dim sh1 As Worksheet, sh2 As Worksheet
  Dim c As Range, f As Range
  
  Set sh1 = Workbooks("workbook1.xlsx").Sheets(1)
  Set sh2 = Workbooks("workbook2.xlsx").Sheets(1)

  For Each c In sh1.Range("A9", sh1.Range("A" & Rows.Count).End(3))
    Set f = sh2.Range("A:A").Find(Left(c.Value, 17), , xlValues, xlWhole, , , False)
    If Not f Is Nothing Then
      sh2.Range("G" & f.Row).Value = sh1.Range("G" & c.Row).Value
    End If
  Next
End Sub

--------------
Let me know the result and I'll get back to you as soon as I can.
Cordially
Dante Amor
--------------​

 

[kevin9999]

I'm trying to get my head around your sample data. For example, in your workbook 2 under "UNIQUE LOCATION", some of the values are not unique (there are two KULMYSINSINLEVEL 2 - which doesn't make them unique). Therefore, which value from workbook 1 would you want returned - as there are two KULMYSINSINLEVEL 2 on there too, one for PIG and one for DOG?

Mindful of what I've said above, this code puts the first instance in. Like with Dante's code, you must have both workbooks open when you run it.

Option Explicit
Sub Compare2columnsVersion2()
    Dim ws1 As Worksheet, ws2 As Worksheet
    Dim a, b, c, i As Long, j As Long
    Set ws1 = Workbooks("workbook1.xlsx").Sheets(1)
    Set ws2 = Workbooks("workbook2.xlsx").Sheets(1)
    
    a = ws2.Range("A2", ws2.Cells(Rows.Count, "A").End(xlUp))
    b = ws1.Range("A9", ws1.Cells(Rows.Count, "G").End(xlUp))
    ReDim c(1 To UBound(a, 1), 1 To 1)
    
    For i = 1 To UBound(a, 1)
        For j = 1 To UBound(b, 1)
            If b(j, 1) Like a(i, 1) & "*" Then
                c(i, 1) = b(j, 7)
                Exit For
            End If
        Next j
    Next i
    ws2.Range("G2").Resize(UBound(c, 1), 1).Value = c
End Sub

 

[TropicalMagic]

Hi both,


Many thanks for responding to my query!

Apologies for being unclear in my initial query, I've simplified what I'm trying to do –

1. Compare only the first 8 characters in Column A from Workbook 1 to Column A from Workbook 2, for matching values, starting from row 2 for both workbooks
2. If there are matching values, copy only the last 3 characters in Column A from Workbook 1 to Column E from Workbook 2
3. Otherwise, return "No Match" in Column E from Workbook 2

* Do note that the number of rows in each workbook is not the same.

Here is my full code used, assuming both workbooks have been opened and will be saved but not closed after being run, still non-functional:

Option Explicit

Sub LAST_3_CHARACTERS()

Application.ScreenUpdating = False
Application.DisplayAlerts = False
Application.AskToUpdateLinks = False

Dim LASTROW1 As Long
LASTROW1 = Workbook1.Sheets(1).Range("A" & Rows.Count).End(xlUp).Row

Dim LASTROW2 As Long
LASTROW2 = Workbook2.Sheets(1).Range("A" & Rows.Count).End(xlUp).Row

Dim Range1 As Range, Range2 As Range, Rng1 As Range, Rng2 As Range
Dim i As Long

Set Range1 = Workbook1.Sheet(1).Range("A2:A" & LASTROW1)
Set Range2 = Workbook2.Sheet(1).Range("A2:A" & LASTROW2)

For i = 2 to LASTROW1
For Each Rng1 in Range1
For Each Rng2 In Range2

If Rng2.Value = Left(Rng1.Value, 10) Then
    Right(Rng1.Value, 3).Copy
    Workbook2.Sheet(1).Range("E" & i).PasteSpecial
End If

Next
Next
Next

MsgBox "READY!"

Application.ScreenUpdating = True
Application.DisplayAlerts = True
Application.AskToUpdateLinks = True

End Sub

I have also simplified the layout as follows -

Here is Workbook 1:

Book2
	A	B	C	D	E
1	FILE ID	ORIGIN	DESTINATION	SERVICE	MOVEMENT
2	TSNSIN22DOG	TSN	SIN	22	DOG
3	TSNSIN11DOG	TSN	SIN	11	DOG
4	TSNSIN22DOG	TSN	SIN	22	DOG
5	TSNSIN11OWL	TSN	SIN	11	OWL
6	SHASIN11DOG	SHA	SIN	11	DOG
7	SHASIN22DOG	SHA	SIN	22	DOG
8	SHASIN11DOG	SHA	SIN	11	DOG
9	SHASIN22DOG	SHA	SIN	22	DOG
10	SHASIN11CAT	SHA	SIN	11	CAT
11	SHASIN22CAT	SHA	SIN	22	CAT
12	SHASEL11CAT	SHA	SEL	11	CAT
13	SHASEL22CAT	SHA	SEL	22	CAT
14	SHASEL11DOG	SHA	SEL	11	DOG
15	SHASEL22DOG	SHA	SEL	22	DOG
16	SHASEL11DOG	SHA	SEL	11	DOG
17	SHASEL22DOG	SHA	SEL	22	DOG
WORKBOOK 1

Cell Formulas
Range	Formula
A2:A17	A2	=B2&C2&D2&E2

Cells with Data Validation
Cell	Allow	Criteria
D2:D17	List	=Services

Here is Workbook 2:

Book2
	A	B	C	D	E
1	FILE ID	ORIGIN	DESTINATION	SERVICE	MOVEMENT
2	TSNSIN22	TSN	SIN	22
3	TSNSIN11	TSN	SIN	11
4	TSNSIN22	TSN	SIN	22
5	TSNSIN11	TSN	SIN	11
6	SHASEL11	SHA	SEL	11
7	SHASEL22	SHA	SEL	22
8	SHASEL11	SHA	SEL	11
9	SHASEL22	SHA	SEL	22
10	SHASEL11	SHA	SEL	11
11	SHASEL22	SHA	SEL	22
WORKBOOK 2

Cell Formulas
Range	Formula
A2:A11	A2	=B2&C2&D2

Cells with Data Validation
Cell	Allow	Criteria
D2:D11	List	=Services

Here is the expected result in Workbook 2:

Book2
	A	B	C	D	E
1	FILE ID	ORIGIN	DESTINATION	SERVICE	MOVEMENT
2	TSNSIN22	TSN	SIN	22	DOG
3	TSNSIN11	TSN	SIN	11	DOG
4	TSNSIN22	TSN	SIN	22	DOG
5	TSNSIN11	TSN	SIN	11	OWL
6	SHASEL11	SHA	SEL	11	CAT
7	SHASEL22	SHA	SEL	22	CAT
8	SHASEL11	SHA	SEL	11	DOG
9	SHASEL22	SHA	SEL	22	DOG
10	SHASEL11	SHA	SEL	11	DOG
11	SHASEL22	SHA	SEL	22	DOG
WORKBOOK 2 FINAL RESULT

Cell Formulas
Range	Formula
A2:A11	A2	=B2&C2&D2

Cells with Data Validation
Cell	Allow	Criteria
D2:D11	List	=Services

I'm also trying to figure out how to implement your solutions into the code but I'm also wondering if I missed anything as they are not working as well.

Would appreciate any new ideas too!

Many thanks in advance!

 

[TropicalMagic]

Hi both DanteAmor and kevin9999,


Many thanks to you both for offering solutions!

I have applied DanteAmor's solution and found it to suit my needs!


Here is what I was trying to do –

1. Compare only the first 8 characters in Column A from Workbook 1 to Column A from Workbook 2, for matching values, starting from row 2 for both workbooks
2. If there are matching values, copy only the last 3 characters in Column A from Workbook 1 to Column E from Workbook 2

* Do note that the number of rows in each workbook is not the same.

Workbook1:

FORUM LAYOUT.xlsx
	A	B	C	D	E
1	FILE ID	ORIGIN	DESTINATION	SERVICE	MOVEMENT
2	TSNSIN22DOG	TSN	SIN	22	DOG
3	TSNSIN11DOG	TSN	SIN	11	DOG
4	TSNSIN22DOG	TSN	SIN	22	DOG
5	TSNSIN11OWL	TSN	SIN	11	OWL
6	SHASIN11DOG	SHA	SIN	11	DOG
7	SHASIN22DOG	SHA	SIN	22	DOG
8	SHASIN11DOG	SHA	SIN	11	DOG
9	SHASIN22DOG	SHA	SIN	22	DOG
10	SHASIN11CAT	SHA	SIN	11	CAT
11	SHASIN22CAT	SHA	SIN	22	CAT
12	SHASEL11CAT	SHA	SEL	11	CAT
13	SHASEL22CAT	SHA	SEL	22	CAT
14	SHASEL11DOG	SHA	SEL	11	DOG
15	SHASEL22DOG	SHA	SEL	22	DOG
16	SHASEL11DOG	SHA	SEL	11	DOG
17	SHASEL22DOG	SHA	SEL	22	DOG
WORKBOOK 1

Cell Formulas
Range	Formula
A2:A17	A2	=B2&C2&D2&E2

Cells with Data Validation
Cell	Allow	Criteria
D2:D17	List	=Services

Workbook 2:

FORUM LAYOUT.xlsx
	A	B	C	D	E
1	FILE ID	ORIGIN	DESTINATION	SERVICE	MOVEMENT
2	TSNSIN22	TSN	SIN	22
3	TSNSIN11	TSN	SIN	11
4	TSNSIN22	TSN	SIN	22
5	TSNSIN11	TSN	SIN	11
6	SHASEL11	SHA	SEL	11
7	SHASEL22	SHA	SEL	22
8	SHASEL11	SHA	SEL	11
9	SHASEL22	SHA	SEL	22
10	SHASEL11	SHA	SEL	11
11	SHASEL22	SHA	SEL	22
WORKBOOK 2

Cell Formulas
Range	Formula
A2:A11	A2	=B2&C2&D2

Cells with Data Validation
Cell	Allow	Criteria
D2:D11	List	=Services

Here is the full working code:

Option Explicit

Sub LAST_3_CHARACTERS()

Application.ScreenUpdating = False
Application.DisplayAlerts = False
Application.AskToUpdateLinks = False

Dim LASTROW1 As Long
LASTROW1 = Workbook1.Sheets(1).Range("A" & Rows.Count).End(xlUp).Row

Dim LASTROW2 As Long
LASTROW2 = Workbook2.Sheets(1).Range("A" & Rows.Count).End(xlUp).Row

Dim sh1 As Worksheet, sh2 As Worksheet
Dim c As Range, f As Range

Set sh1 = Workbook1.Sheets(1)
Set sh2 = Workbook2.Sheets(1)

For Each c In sh1.Range("A2", sh1.Range("A" & Rows.Count).End(3))
Set f = sh2.Range("A:A").Find(Left(c.Value, 8), , xlValues, xlWhole, , , False)
If Not f Is Nothing Then
    sh2.Range("E" & f.Row).Value = sh1.Range("A" & c.Row).Value
End If
Next

MsgBox "READY!"

Application.ScreenUpdating = True
Application.DisplayAlerts = True
Application.AskToUpdateLinks = True

End Sub

Many thanks!!

 

[sofas]

Actually there are 17.
------------

In book 1, these 2 data (the 17 characters on the left) are repeated, so if you find the data in book 2, then you put CAT first and then DOG. Finally only "DOG" remains in the cell.
What should be done in those cases, or is it a typo in your example and that's not going to happen.

Workbook1.xlsx
	A
12	SHACNNYCUSLEVEL 1CAT
13	SHACNNYCUSLEVEL 1DOG
1

Cell Formulas
Range	Formula
A12:A13	A12	=B12&C12&D12&E12&F12&G12

-------------

Try the following macro. Set the names of your books in the data highlighted in blue.
Note: the 2 books must be open.

Sub Compare2columns()
  Dim sh1 As Worksheet, sh2 As Worksheet
  Dim c As Range, f As Range
  
  Set sh1 = Workbooks("workbook1.xlsx").Sheets(1)
  Set sh2 = Workbooks("workbook2.xlsx").Sheets(1)

  For Each c In sh1.Range("A9", sh1.Range("A" & Rows.Count).End(3))
    Set f = sh2.Range("A:A").Find(Left(c.Value, 17), , xlValues, xlWhole, , , False)
    If Not f Is Nothing Then
      sh2.Range("G" & f.Row).Value = sh1.Range("G" & c.Row).Value
    End If
  Next
End Sub

--------------
Let me know the result and I'll get back to you as soon as I can.
Cordially
Dante Amor
--------------​

Hello. Thank you for this beautiful symbol as usual. How can you add another column condition so that the comparison is made, for example, in column A and column C?