Find only First Value Excel VBA

[Kramer328]

Hello,

I am trying to copy text from one open workbook to another using vba. I want to have the macro find any values in column I of Worksheet1 and compare them to column A of Worksheet2. If it there is a match, I want to copy the cells that is 8 columns to the left of column I on Worksheet1 and paste it into the cell that is 4 column to the right of the matching cell on Worksheet2. However, I only want to do this for the first match that the macro finds. If it finds another identical match, I want the macro to copy/paste the value 8 colums to the left into Worksheet2. Is this possible? Both of my worksheets have headers and I would like the macro to ignore these cells when searching (Start at A2 instead of A1 for the search). Any help would be greatly appreciated!

Here is an example of what each worksheet should look like after running the macro.
Worksheet1:

A	B	C	D	E	F	G	H	I
Header1	Header2	Header3	Header4	Header5	Header6	Header7	Header8	Header9
1								A
2								B
3								A
4								C
5								B
6								C

<tbody>
</tbody>

​

Worksheet2 After Macro Runs:

A	B	C	D
Header1	Header2	Header3	Header4
A			1
B			2
A			3
C			4
B			5
C			6

<tbody>
</tbody>

​

 

[MickG]

Try this:-

[COLOR="Navy"]Sub[/COLOR] MG24Oct34
[COLOR="Navy"]Dim[/COLOR] Rng [COLOR="Navy"]As[/COLOR] Range, Dn [COLOR="Navy"]As[/COLOR] Range, n [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long,[/COLOR] c [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long[/COLOR]
[COLOR="Navy"]Dim[/COLOR] Q [COLOR="Navy"]As[/COLOR] Variant, Ray() [COLOR="Navy"]As[/COLOR] Variant, K [COLOR="Navy"]As[/COLOR] Variant
[COLOR="Navy"]With[/COLOR] Sheets("Sheet1")
    [COLOR="Navy"]Set[/COLOR] Rng = .Range("I2", .Range("I" & Rows.Count).End(xlUp))
[COLOR="Navy"]End[/COLOR] With

[COLOR="Navy"]With[/COLOR] CreateObject("scripting.dictionary")
.CompareMode = vbTextCompare

[COLOR="Navy"]For[/COLOR] [COLOR="Navy"]Each[/COLOR] Dn [COLOR="Navy"]In[/COLOR] Rng
    [COLOR="Navy"]If[/COLOR] Not .Exists(Dn.Value) [COLOR="Navy"]Then[/COLOR]
        ReDim Preserve Ray(1)
        Ray(1) = Dn.Offset(, -8)
        .Add Dn.Value, Ray
    [COLOR="Navy"]Else[/COLOR]
       Q = .Item(Dn.Value)
       ReDim Preserve Q(UBound(Q) + 1)
       Q(UBound(Q)) = Dn.Offset(, -8)
      .Item(Dn.Value) = Q
    [COLOR="Navy"]End[/COLOR] If
[COLOR="Navy"]Next[/COLOR]

[COLOR="Navy"]With[/COLOR] Sheets("Sheet2")
    [COLOR="Navy"]Set[/COLOR] Rng = .Range("A2", .Range("A" & Rows.Count).End(xlUp))
[COLOR="Navy"]End[/COLOR] With

[COLOR="Navy"]For[/COLOR] [COLOR="Navy"]Each[/COLOR] K [COLOR="Navy"]In[/COLOR] .keys
  c = 0
  [COLOR="Navy"]For[/COLOR] [COLOR="Navy"]Each[/COLOR] Dn [COLOR="Navy"]In[/COLOR] Rng
      [COLOR="Navy"]If[/COLOR] Dn.Value = K [COLOR="Navy"]Then[/COLOR]
          c = c + 1
          [COLOR="Navy"]If[/COLOR] c <= UBound(.Item(K)) [COLOR="Navy"]Then[/COLOR]
              Dn.Offset(, 3).Value = .Item(K)(c)
          [COLOR="Navy"]End[/COLOR] If
        [COLOR="Navy"]End[/COLOR] If
    [COLOR="Navy"]Next[/COLOR] Dn
[COLOR="Navy"]Next[/COLOR] K

[COLOR="Navy"]End[/COLOR] [COLOR="Navy"]With[/COLOR]
[COLOR="Navy"]End[/COLOR] [COLOR="Navy"]Sub[/COLOR]

Regards Mick

 

[Kramer328]

Hey Mick,

Works like a charm. Thanks so much!

 

[MickG]

You're welcome