Solved How to match value in separate sheets and copy/past the row?

July 1, 2015 at 11:24:54
Specs: Macintosh
Hello everybody,

So basically the situation:

In the sheet1 (master reports) column A i have code such as AAA-12122 and then all details in the other columns.
In the Sheet2 (new products) column A i have so code such as AAA-3432 and then I have all the information about this code in the same row. Both sheets have the same format.

What I would like to do if a code that take codes on by one in the sheet2 and check if it already existe in the sheet1. If yes i want to override all information and copy from the sheet2 to sheet1 to the corresponding code.

Is it possible?

Thank you in advance for your help!!!!


I am new on VBA and I would like to know if it is possible to write a code which:


See More: How to match value in separate sheets and copy/past the row?

Report •


#1
July 1, 2015 at 15:53:05
✔ Best Answer
Try this:

Option Explicit
Sub ReplaceData()
Dim lastRw1, lastRw2, nxtRw, m
'Determine last row with data, Sheet1
  lastRw1 = Sheets(1).Range("A" & Rows.Count).End(xlUp).Row
'Determine last row with data, Sheet2
  lastRw2 = Sheets(2).Range("A" & Rows.Count).End(xlUp).Row
'Loop through Sheet 2, Column A
     For nxtRw = 2 To lastRw2
'Search Sheet1 Column A for value from Sheet 2
        With Sheets(1).Range("A2:A" & lastRw1)
          Set m = .Find(Sheets(2).Range("A" & nxtRw), lookat:=xlWhole)
'Copy Sheet2 row if match is found
            If Not m Is Nothing Then
              Sheets(2).Range("A" & nxtRw).EntireRow.Copy _
              Sheets(1).Range("A" & m.Row)
            End If
        End With
     Next
End Sub

Click Here Before Posting Data or VBA Code ---> How To Post Data or Code.


Report •

#2
July 1, 2015 at 22:17:56
Hello DerbyDad03,

I just try your code and it works perfectly!!!! Thank you so much!

I have a last question:

In the sheet2 column A, It can happen that I have several code in the same cell such as: MDM-11223; MDM-3674;MDM-1672

But in the sheet1 columnA, I will have only one of this code for instance the last one: MDM-1672 (it can happen as well to have multiple code inside the same sell)

Is that possible to do the same code and check every values inside one cell?

I thought about using the split function...
Thank you in advance!

message edited by manu31


Report •

#3
July 2, 2015 at 05:27:24
First, I would like to request that we stop using the word "code" for 2 different things. It makes reading your posts confusing. Let's use "code" for the VBA code and "string" for your values.

Second, I'm confused by this paragraph:

But in the sheet1 columnA, I will have only one of this code for instance the last one: MDM-1672 (it can happen as well to have multiple code inside the same sell)

Is it always the last string or is that just an example?

Are all strings separated by a semi colon?

What do you mean by the last sentence? Do you mean that both Sheet1 and Sheet2 can have multiple strings in the same cell?

Finally, please don't take this the wrong way, but you are guilty of something we see in these forums very often. In the original post, a specific set of requirements is posted and a solution is offered that meets those requirements. Then, in subsequent posts, we see things like "Thanks, that works great. Now can you add this?" then more/different requirements are added. This means that we have to go back and either modify the solution that was already offered or sometimes start from scratch so that we don't end up with bloated, inefficient code. We have to set up a test workbook again and repeat a lot of the steps that we already did. I understand the desire to "keep it simple" but in the case of VBA code, which has to be very specific to the given requirements, it is best to just lay it all out there right from the start. In the end it saves everyone time and effort.

Click Here Before Posting Data or VBA Code ---> How To Post Data or Code.


Report •

Related Solutions

#4
July 2, 2015 at 06:08:40
I'm really sorry about that. I'll take your advices for next time.

So I have 2 sheets, in both sheets column A in my cells I have multiple strings such as: AAA-21,BBB-23,...

In the sheet1 it is my master report and in sheet2 it's new items. What I'd like to do it is a macro who can read each cells (with all strings separates with a coma inside the cell) of the columnA and see if there is a match. If yes, so the row (in the sheet2) will be copied and past in the matched row (in sheet1).

Thanks and sorry again.


Report •

#5
July 2, 2015 at 07:17:11
Before I do any more work, I want to make sure that we are on the same page.

This is what I know and don't know:

Some cells on both Sheet1 and Sheet2 contain a single string, some cells contain multiple strings.

In the cells with multiple strings, the strings are separated by commas.

- Are they separated by a comma and a space or just a comma? e.g.

AAA-123, BBB-456

Or

AAA-123,BBB-456

When there are multiple strings, does the number of strings vary or is it always a specific number? If it's a specific number, what is that number? If it varies, is there a maximum number that might be in any given cell?

For each individual string on Sheet2, will there only be a single match on Sheet1? In other words, if Sheet2 contains AAA-123, either individually in a cell or as one of the multiple strings in a cell, will AAA-123 be found only one single time on Sheet1 or could there be more than one occurrence, meaning more than one copy/paste operation for that string?

If a string on Sheet2 looks like AAA-123, is it possible to have a string on Sheet1 that looks like AAA-1234? The reason I ask is that if the code uses a "partial string" search, AAA-1234 is going to be a match for AAA-123 since AAA-1234 contains AAA-123. (I was not concerned with partial matches when I thought there was only one string in each cell but now that you've told me that there may be multiple strings in some cells, things get a bit more tricky. Thus my reason for bringing up the issues related to providing a "simple" set of requirements vs. the complete set.)

Now, just for clarity, if Sheet2 has a cell that looks like this...

AAA-123, BBB-456, CCC-789

...and Sheet1 has a cell that looks like any of these, that would be a match and the entire row would be replaced, right?

BBB-456

AAA-610, BBB-456

CCC-789, AAA-123, BBB-456

If you think it would help, please post some example data from both sheets, if only for clarification. Make sure you use the pre tags to make the data easier to read.

I may have more questions related to this task once I get started, but for now that it. You should also be aware that we have a holiday weekend coming up and I may not spend too much time on this code until next week.

Click Here Before Posting Data or VBA Code ---> How To Post Data or Code.

message edited by DerbyDad03


Report •

#6
July 2, 2015 at 08:53:08
Thanks for your answer.

1- The strings are separated with coma and space:

MDM-123, MDM-456

2-It has to match at least one string exactly in the occurrence. But it can have several matches.

3-There is no specific number of strings, so it can be 1 or no maximum.

I improved your macro and it almost works the way I want. I still have issue when in the sheet one have more strings than the sheet2 it doesn't do anything.

If you would like. Put in columnA in sheet1:

MDM-123 

in columnA in sheet 2:

MDM-321,MDM123 

It does want I want!!!

However If i want to re launch the macro with:

in sheet1 column A I have this know:

MDM-321,MDM123

And In sheet2 I just put:

MDM-123

nothing happened. I mean the row does not copy/past

I am very close...

Sub ReplaceData2()
Dim LastRw1 As Long, LastRw2 As Long, NxtRw As Long
Dim i As Integer
Dim m As Range
Dim Tb
 

  LastRw1 = Sheets(1).Range("A" & Rows.Count).End(xlUp).Row 'Determine last row with data, Sheet2
  LastRw2 = Sheets(2).Range("A" & Rows.Count).End(xlUp).Row 'Loop through Sheet 2, Column A

With Worksheets(2)
    LastRw2 = .Range("A" & Rows.Count).End(xlUp).Row
    For NxtRw = 2 To LastRw2
        Tb = Split(.Range("A" & NxtRw), ",")
        For i = 0 To UBound(Tb)
            With Sheets(1).Range("A2:A" & LastRw1)
                Set m = .Find(Tb(i), LookAt:=xlWhole)
                If Not m Is Nothing Then
                   Sheets(2).Range("A" & NxtRw).EntireRow.Copy _
                    Sheets(1).Range("A" & m.Row)
              
                    Set m = Nothing

                End If
            End With
        Next i
    Next NxtRw
End With
End Sub

Thanks

message edited by manu31


Report •

#7
July 2, 2015 at 09:18:23
I will continue testing, but I have to ask you to be more careful when you post example data.

In your latest response you said:

1- The strings are separated with coma and space:

Then you said:

in columnA in sheet 2:
MDM-321,MDM123

and

in sheet1 column A I have this know:
MDM-321,MDM123

Hummm...we seem to be missing the space in both examples, so I have to guess that you actually have MDM-321, MDM123. The problem is that when I start "guessing" about your data, the possibility exists that I will guess wrong and end up wasting even more time.

While this may seem like I am picking a nit, there are cases where that space being there or not can mean the difference between code that works and code that fails horribly.

Click Here Before Posting Data or VBA Code ---> How To Post Data or Code.


Report •

#8
July 2, 2015 at 10:54:53
Further to my comment about being careful when you post your example data, I noticed this while trying your suggestion:

You said:

"If you would like. Put in columnA in sheet1:

MDM-123 

in columnA in sheet 2:

MDM-321,MDM123 

It does want I want!!!"

I doubt it does what you want, since I don't see any matches.

MDM-123 is not a match for MDM123.

These little things matter, especially when asking for someone else to test your code.

Click Here Before Posting Data or VBA Code ---> How To Post Data or Code.


Report •

#9
July 2, 2015 at 11:08:22
I am sorry... However I found my mistake!

Instead of:

Set m = .Find(Tb(i), LookAt:=xlWhole)

I put:

Set m = .Find(Tb(I), LookAt:=xlPart)

And it works in both way.

But still something wrong with this change it erase all strings in sheet1 and replace by strings from sheet2. Whereas I would like to have all of them in sheet1 columnA.


Report •

#10
July 2, 2015 at 11:20:46
I was just about to suggest xlPart, but I see that you found that solution already.

re: But still something wrong with this change it erase all strings in sheet1 and replace by strings from sheet2. Whereas I would like to have all of them in sheet1 columnA.

That is because the code is replacing the EntireRow, which is what you said you wanted to do way back in your original post:

What I would like to do if a code that take codes on by one in the sheet2 and check if it already existe in the sheet1. If yes i want to override all information and copy from the sheet2 to sheet1 to the corresponding code.

You said "all information" which, at least to me, means the entire row.

I even asked you that specific question in Response # 5, putting the words entire row in italics for emphasis. Are you now saying that you don't want to copy all information from Sheet2? Do you only want to copy some? If so, what information do you want to copy?

Click Here Before Posting Data or VBA Code ---> How To Post Data or Code.


Report •

#11
July 2, 2015 at 11:34:58
The MDM numbers of the sheet1 columnA has to remain.

However in the sheet2 columnA there is:

1-the matching string
2-And if there if new string in the same cell as the matching string so I would like to add them as well in the cell of the columnA sheet1.

After that, my code will be complete :)


Report •

#12
July 2, 2015 at 12:20:41
...and once again we are adding requirements, and not trivial ones.

Leaving Sheet1 Column A as is is fairly simple. Instead of copying the EntireRow, all you would need to do is copy the data from Sheet2 Column B to the end of your data and paste it into Sheet1 Column B. e.g. to copy data from Columns B:Q, try this:

Sheets(2).Range("B" & NxtRw & ":Q" & NxtRw).Copy _
                    Sheets(1).Range("B" & m.Row)

In this case, I have hardcoded Column Q into the instruction. You could also determine the last Column with data and use that to copy the required range.


As far as adding missing strings to Sheet 1 Column A, that is a bit more difficult.

As you have found, you need to use both Split and a partial find (xlPart) in order to find individual strings within cells that contain multiple strings. Now the code has to go back and find out what strings are missing from the cell where it found an individual match.

e.g.:

Sheet2 Column A:

MDM-123, MDM-345, MDM-678

Sheet1 Column A:

MDM-000, MDM-345, MDM-999

The .Find with xlPart is going to see a match (MDM-345) in those 2 cells and do the copy/paste. You now have to add code - in that same section - that loops through the current Split array (Tb) comparing each element in the array with each individual string in Sheet1 Column A.

One possible way to do that would be to loop through the current Split array (Tb) and try to ".Find xlPart" each element in Sheet1 A m.row.

Earlier, when you were looking for a Match, you used:

If Not m Is Nothing Then

Now, since you are looking for a non-match, you could use:

If m Is Nothing Then

If the current array element is not found, you could append it to the end:

Untested

If m Is Nothing Then
  Sheets(1).Range("A" & m.Row) = _ 
        Sheets(1).Range("A" & m.Row) & ", " & Tb(i)

In the example I used above, each time through the array loop, you would see something like this in Sheet1 A m.Row:

MDM-000, MDM-345, MDM-999
MDM-000, MDM-345, MDM-999, MDM-123
MDM-000, MDM-345, MDM-999, MDM-123, MDM-678

I do not have time to code this, so I'll leave it up to you to give it a try.

You might also want to look through this tutorial which might make troubleshooting your code a little easier:

http://www.computing.net/howtos/sho...


message edited by DerbyDad03


Report •

#13
July 2, 2015 at 13:17:35
I found a possible problem with your Split instruction.

Let's say you have this:

Sheet2 Column A:

MDM-123, MDM-345, MDM-678

Sheet1 Column A:

MDM-345, MDM-000, MDM-999

Your Split instruction is going to produce the following array:

"MDM-123"
" MDM-345"
" MDM-678"

Note the leading spaces in the 2nd and 3rd elements. Since Sheet1 Column A begins with "MDM-345", that is not going to be a match for " MDM-345".

You might want to try this to strip off the leading space from your array elements:

Set m = .Find(Trim(Tb(i)), LookAt:=xlPart)

(This is a perfect example of why the little things matter. Whether your strings are separated by commas or by commas and spaces really makes a huge difference.)

Click Here Before Posting Data or VBA Code ---> How To Post Data or Code.


Report •

#14
July 4, 2015 at 01:28:26
Hi DerbyDad03,
First of all Happy 4th of July!!!

Then I finish my code, it is not so pretty but its works perfectly. And thanks for your last advise.


Thank you again for everything.


Sub ReplaceData2()
Dim LastRw1 As Long, LastRw2 As Long, NxtRw As Long
Dim i As Integer
Dim m As Range
Dim Tb

LastRw1 = Sheets(1).Range("A" & Rows.Count).End(xlUp).Row 'Determine last row with data, Sheet2
LastRw2 = Sheets(2).Range("A" & Rows.Count).End(xlUp).Row 'Loop through Sheet 2, Column A

With Worksheets(2)
    LastRw2 = .Range("A" & Rows.Count).End(xlUp).Row
    For NxtRw = 2 To LastRw2
    
        Tb = Split(.Range("A" & NxtRw), ",")
        
            For i = 0 To UBound(Tb)
        
                With Sheets(1).Range("A2:A" & LastRw1)
            
                    Set m = .Find(Trim(Tb(i)), LookAt:=xlPart)
                
                    If Not m Is Nothing Then
                    Sheets(1).Range("A" & m.Row) = Sheets(1).Range("A" & m.Row) & "," & Sheets(2).Range("A" & m.Row)
                   ' ", " & Tb(i)
                    Sheets(2).Range("B" & NxtRw & ":Q" & NxtRw).Copy _
                    Sheets(1).Range("B" & m.Row)
                    
                    Set m = Nothing
                    
                End If
                
            End With
            
        Next i
        
    Next NxtRw
    
End With


'*****************************************
'Erase strings duplicates in each cell    *
'*****************************************
    Dim starval As String
    Dim finval As String
    Dim strarray() As String
    Dim x As Long
    Dim k As Long
    Dim cell As Range
    Dim rw As Long
    
' step through each cell in range
    
    For Each cell In Sheets(1).Range("A1:A1000")
        Erase strarray ' erase array
        finval = "" ' erase final value"
        starval = cell.Value
        On Error Resume Next
         
        strarray = Split(starval, ",")
         
         'Step through length of string and look for duplicate
        For rw = 0 To UBound(strarray)
             
            For k = rw + 1 To UBound(strarray)
                If Trim(strarray(k)) = Trim(strarray(rw)) Then
                    strarray(k) = "" 'if duplicate clear array value
                End If
            Next k
        Next rw
         
         ' combine all value in string less duplicate
        For x = 0 To UBound(strarray)
            If strarray(x) <> "" Then
                 
                finval = finval & Trim(strarray(x)) & ","
            End If
             
        Next x
         ' remove last space and comma
        finval = Trim(finval)
        finval = Left(finval, Len(finval) - 1)
         ' output value to Column J
        cell.Offset(0, 0).Value = finval
         
    Next cell
     
End Sub


Report •

#15
July 4, 2015 at 04:35:20

Report •

#16
July 5, 2015 at 02:53:38
Hi DerbyDa03,

I might said victory before testing my code in every possible ways...
After testing my code with strings in random position it appears it doesn't wok properly

So I changed it and here is the code, what do you think?

Sub MDMNumbers()
    Dim LastRw1 As Long, LastRw2 As Long, NxtRw As Long
    Dim i As Integer
    Dim m As Range
    Dim Tb
 
    LastRw1 = Sheets(1).Range("A" & Rows.Count).End(xlUp).Row    'Determine last row with data, Sheet2
    LastRw2 = Sheets(2).Range("A" & Rows.Count).End(xlUp).Row    'Loop through Sheet 2, Column A
    With Worksheets(2)
        LastRw2 = .Range("A" & Rows.Count).End(xlUp).Row
        For NxtRw = 2 To LastRw2
 
            Tb = Split(.Range("A" & NxtRw), ",")
            For i = 0 To UBound(Tb)
                With Sheets(1).Range("A2:A" & LastRw1)
                    Set m = .Find(Trim(Tb(i)), LookAt:=xlPart)
 
                    If Not m Is Nothing Then
                        'on rajoute que les partie manquantes dans la colonne A du sheets(1)
                        For it = 0 To UBound(Tb)
                            If InStr(Sheets(1).Range("A" & m.Row), Tb(it)) < 0 Then Sheets(1).Range("A" & m.Row) = Sheets(1).Range("A" & m.Row) & "," & Tb(it)
                        Next
                        Sheets(2).Range("B" & NxtRw & ":Q" & NxtRw).Copy _
                                Sheets(1).Range("B" & m.Row)
                        Set m = Nothing
                        Exit For    ' ici on sort sinon l'operation se renouvelera a chaque occurence de tb(i)ce qui n'est pas necessaire puisque c'est fait en une seule fois par la 2 eme boucle for pour le tb
                    End If
                End With
            Next i
        Next NxtRw
    End With
End Sub

It is the only issue, after that my code will be perfect.

Thank you again if you can get me on the right track because i spend my whole saturday night on it and i am really blocked.

Manu

message edited by manu31


Report •

#17
July 5, 2015 at 05:33:50
I have mentioned the fact that your example data does not match your text description multiple times. In Response #6 you said that your strings were separated by a comma and a space. However, in every example of Response #16, your strings are only separated by a comma.

Since the space in a integral part of your data, I will not continue to troubleshoot your issues until you fix your example data. I understand that everyone makes typographical errors on occasion, but you seem to keep making the same error by leaving out the space. For all I know, you are using incorrect strings in your spreadsheet and that is why you are having problems. That is probably not the issue, but I have no way of knowing that. I can only go by what you post.

I will no longer respond to posts that contain examples of data in the incorrect format.

Click Here Before Posting Data or VBA Code ---> How To Post Data or Code.


Report •

#18
July 5, 2015 at 06:07:14
My data are without space just separated with a coma ( As i found it easier), such as:

Case1:
ColumnA sheet2 cell10: MDM-123,MDM345

ColumnA sheet1 cell20: MDM-9999,MDM-5674,MDM-345

Result:
ColumnA sheet1 cell20:
MDM-9999,MDM-5674,MDM-345,MDM-123

Or case2:

ColumnA sheet2 cell20: MDM-9999,MDM-5674,MDM-345

ColumnA sheet1 cell10: MDM345

Result:
ColumnA sheet1 cell20: MDM-9999,MDM-5674,

MDM-345


Report •

#19
July 5, 2015 at 13:30:55
It would have been nice if you had told me that you changed your data format.

If that is the case, why do you still have the Trim function in the code?

And why does some of your latest example data have a hyphen while some does not?

Instead of making it easier for me to help you, you just keep making it harder.

I also see that the thread is marked as Solved again after I reset the Best Answer since you told me that the code wasn't working for you.

I am really confused. Are we done or not?

Click Here Before Posting Data or VBA Code ---> How To Post Data or Code.

message edited by DerbyDad03


Report •

#20
July 5, 2015 at 14:20:28
Its ok just let you know that i learn VBA by myself and it is the first time that i use forums to get some help, so i don't really know how it works (now i know). And english is not my mother tongue so it makes it more difficult to explain something very technical.

And Yes i finish the macro and this times it works as I want. I am still working on it to improve it because I will use it with a large dataset.

Can i have your opinion about the macro? If you see any improvement to make?

Sub MDMNumbers()

Dim LastRw1 As Long, LastRw2 As Long, NxtRw As Long, rng1 As Range, rng2 As Range
Dim i As Long, m As Range, tb() As String, celVal As String, notFound As Boolean
Dim additions1 As String, additions2 As String

LastRw1 = Worksheets(1).Range("A" & Worksheets(1).Rows.Count).End(xlUp).Row + 1
LastRw2 = Worksheets(2).Range("A" & Worksheets(2).Rows.Count).End(xlUp).Row

notFound = True

For NxtRw = 2 To LastRw2
    celVal = Worksheets(2).Range("A" & NxtRw).Value2

    If Len(celVal) > 0 Then
        tb = Split(celVal, ",")
        For i = 0 To UBound(tb)
            Set m = Worksheets(1).Columns(1).Find(Trim(tb(i)), LookAt:=xlPart)
            If Not m Is Nothing And notFound Then
                Set rng1 = Worksheets(2).Range("B" & NxtRw & ":Q" & NxtRw)
                Set rng2 = Worksheets(1).Range("B" & m.Row & ":Q" & m.Row)
                rng1.Copy rng2

                With Worksheets(2).Range("A" & NxtRw)
                    additions1 = Replace(.Value2, "," & tb(i), vbNullString)
                    additions1 = Replace(additions1, tb(i) & ",", vbNullString)
                    additions1 = Replace(additions1, tb(i), vbNullString)
                End With

                With Worksheets(1).Range("A" & m.Row)
                    additions2 = Replace(.Value2, "," & tb(i), vbNullString)
                    additions2 = Replace(additions2, tb(i) & ",", vbNullString)
                    additions2 = Replace(additions2, tb(i), vbNullString)

                    If Len(additions2) > 0 Then
                        If Len(additions1) > 0 Then
                            .Value2 = tb(i) & "," & additions2 & "," & additions1
                        Else
                            .Value2 = tb(i) & "," & additions2
                        End If
                    Else
                        .Value2 = tb(i) & "," & additions1
                    End If
                End With
                Set m = Nothing
                notFound = False
            End If
        Next
        If notFound Then
            Set rng1 = Worksheets(2).Range("A" & NxtRw & ":Q" & NxtRw)
            Set rng2 = Worksheets(1).Range("A" & LastRw1 & ":Q" & LastRw1)
            rng1.Copy rng2
            LastRw1 = LastRw1 + 1
        End If
        notFound = True
    End If
Next
End Sub


Report •

#21
July 6, 2015 at 07:02:33
re: Can i have your opinion about the macro? If you see any improvement to make?

I don't see any comments so it's hard for me to figure out what you are doing and/or why you are doing it the way you are. I could rack my brain and try to decipher your code, but that's way too much work for me.

A wise man once said:

"Code Tells You How, Comments Tell You Why"

Comments not only help others understand your code, but will also help you remember why you wrote what you wrote. Imagine a year from now, when the format of your data changes or the requirements of the code change. It would be nice to be able to look at the code, read the comments and quickly determine your thought process at the time the code was written. That will help make any required changes much easier.

I don't know how many hundreds of macros I've written, many (most?) of them for other people in forums such as this one. I've got dozens of macros on my own system that I use almost daily. When I look at some of these older macros, I can't possibly remember what I was thinking at the time I wrote the code. Without my comments I'd have to spend way too much time figuring out how the code does what it does before I can begin to make changes.

Add some comments and I'll look over your code. Comments should include items such as:

- The description of variables, e.g. Explain the purpose of notFound, tb, etc.
- The reason for the use of certain functions, e.g. Explain the purpose of the Trim function within the .Find instruction, explain why Split is used, etc.
- The purpose of various "sections" of code e.g. Explain what the additions1 and additions2 sections of code do.

You don't need to add paragraphs worth of comments, just a few words that explain what "comes next" like I did in Response #2.

Click Here Before Posting Data or VBA Code ---> How To Post Data or Code.


Report •

#22
July 7, 2015 at 11:40:58
Hello Derbydad03,

So as you ask aI add comments on my code and you were right it will allow me to remember me how it works like this. And especially to improve it.
I test it on a large dataset and i'd would say that it is quite slow...

If you have any questions i'd be glad to answers about my code. And I hope this time I made myself clear.


Sub MDMNumbers()

Dim LastRw1 As Long, LastRw2 As Long, NxtRw As Long, rng1 As Range, rng2 As Range
Dim i As Long, m As Range, tb() As String, celVal As String, notFound As Boolean
Dim additions1 As String, additions2 As String


'LastRw1 refer to the main report
LastRw1 = Worksheets(1).Range("A" & Worksheets(1).Rows.Count).End(xlUp).Row + 1
'LastRw2 refer to the tab wher input will be added to the LastRw1
LastRw2 = Worksheets(2).Range("A" & Worksheets(2).Rows.Count).End(xlUp).Row

' Not found in case that if LastRw1 is not already in LastRw2 so a row will be added in LastRw1 at the first free row
notFound = True

For NxtRw = 2 To LastRw2
    celVal = Worksheets(2).Range("A" & NxtRw).Value2

    If Len(celVal) > 0 Then
'Inside on cell strings (MDMORG number) are separated with a coma
        tb = Split(celVal, ",")
'To look for different strings inside the same cell
        For i = 0 To UBound(tb)
'Look in the worksheet(1), Trim erase any space between the coma in case of a space was put
            Set m = Worksheets(1).Columns(1).Find(Trim(tb(i)), LookAt:=xlPart)
'If one of the string match between the Sheet(2) columnA and Sheet(1) columnA so:
            If Not m Is Nothing And notFound Then
'Copy the row Sheet(2) from columnA to F and past it to the matching row in the sheet(1)
                Set rng1 = Worksheets(2).Range("B" & NxtRw & ":F" & NxtRw)
                Set rng2 = Worksheets(1).Range("B" & m.Row & ":F" & m.Row)
                rng1.Copy rng2
                
'Look for each strings in one cell, if there is a matching string between both sheets, all strings in the same cell from Sheet(2) will be added to the 
matching cell in the Sheet(1)

                With Worksheets(2).Range("A" & NxtRw)
                    additions1 = replace(.Value2, "," & tb(i), vbNullString)
                    additions1 = replace(additions1, tb(i) & ",", vbNullString)
                    additions1 = replace(additions1, tb(i), vbNullString)
                End With

                With Worksheets(1).Range("A" & m.Row)
                    additions2 = replace(.Value2, "," & tb(i), vbNullString)
                    additions2 = replace(additions2, tb(i) & ",", vbNullString)
                    additions2 = replace(additions2, tb(i), vbNullString)

                    If Len(additions2) > 0 Then
                        If Len(additions1) > 0 Then
                            .Value2 = tb(i) & "," & additions2 & "," & additions1
                        Else
                            .Value2 = tb(i) & "," & additions2
                        End If
                    Else
                        .Value2 = tb(i) & "," & additions1
                    End If
                End With
                Set m = Nothing
                notFound = False
            End If
        Next
'if there is no match between both sheets so the entire line of sheet(2) will be copy and
'past in the last free row of the sheet(1)
        If notFound Then
            Set rng1 = Worksheets(2).Range("A" & NxtRw & ":Q" & NxtRw)
            Set rng2 = Worksheets(1).Range("A" & LastRw1 & ":Q" & LastRw1)
            rng1.Copy rng2
            LastRw1 = LastRw1 + 1
        End If
        notFound = True
    End If
Next
'As the code above add strings from sheet(2) I have to delete every duplicates so:
'********************************************************************
'Erase strings duplicates in each cell in sheet(1) columnA    *
'********************************************************************
    Dim starval As String
    Dim finval As String
    Dim strarray() As String
    Dim x As Long
    Dim k As Long
    Dim cell As Range
    Dim rw As Long
    
' step through each cell in range
    For Each cell In Sheets(1).Range("A1:A50")
        Erase strarray ' erase array
        finval = "" ' erase final value"
        starval = cell.Value
        On Error Resume Next
         
        strarray = Split(starval, ",")
         
         'Step through length of string and look for duplicate
        For rw = 0 To UBound(strarray)
             
            For k = rw + 1 To UBound(strarray)
                If Trim(strarray(k)) = Trim(strarray(rw)) Then
                    strarray(k) = "" 'if duplicate clear array value
                End If
            Next k
        Next rw
         
         ' combine all value in string less duplicate
        For x = 0 To UBound(strarray)
            If strarray(x) <> "" Then
                 
                finval = finval & Trim(strarray(x)) & ","
            End If
             
        Next x
         ' remove last space and comma
        finval = Trim(finval)
        finval = Left(finval, Len(finval) - 1)
         ' output value to Column J
        cell.Offset(0, 0).Value = finval
         
    Next cell

End Sub

Thank you again!

message edited by manu31


Report •

Ask Question