Copy certain columns matching column A in two workbooks

[Guest]

I have 1 workbook with sheet1 named Found containing column headings of phone
number, First Name, Last Name, ID , Building, Floor, etc. Sheet2 is named
Not Found
This Found will have a list of phone numbers populated already.

I am recieving multiple spreadsheets with the same column headings from the
different groups. These will have anywhere from 1 row to hundreds of rows
populated. I need to run the macro in the Found workbook that will look at
whatever the active workbook sheet1 is open (received from the groups),
compare the phone numbers (sorted in ascending order)in Column A and if there
is a match paste the data from specific column to the correct column in the
row that is the match.
Preferably with error checking - if any of the cells are already populated
insert a row below the match and paste the data (in diferent color) on that
row including the duplicate number in column A.
If the number in column A exists in one of the group spreadsheets but does
not exist in the Found spread sheet insert a row (at the correct sorted spot)
and copy the data including the phone number.
If the column labeled Cost Center is not populated then paste the cells to
the worksheet Not Found
I have thousands of numbers and about 100 spreadsheets to consolidate.
Lastly can I make this macro run from a toolbar button that shows when the
Found workbook is opened and goes away when it is closed.

 

[Guest]

If someone could help just with the copying of data from the open workbook to
the correct line in the Found workbook (matching the phone number in column
a) and copy the data from the active workbook (one of the workbooks from the
users). It would get me started so maybe I can figure out how to add the
rest later.

Thanks

 

[Guest]

There are two things that I did not cover.
1 - If the incoming phone number is not on the "Found"
worksheet, insert in the sorted spot.
2 - The toolbar button was not addressed.

Try this on copies of your files before you install it
to run on your official files. Find out what it does
and does not do, then re-post for additional assistance.

Also, Where you see "Cost Center" in the code, you will
need to replace with the the actual column number minus 1,
without the quotation marks so that the code will check
the correct cell.


Sub MtchNum()
Dim mRng As Range
Set ws1 = Workbooks(1).Worksheets("Found")
Set ws2 = Workbooks(1).Worksheets("Not Found")
Set ws3 = Workbooks(2).Worksheets("Sheet1")
lr = Cells(Rows.Count, 1).End(xlUp).Row
ws3.Activate
For i = 2 To ws3.Cells(Rows.Count, 1).End(xlUp).Row + 1
myVal = Cells(i, 1).Value
ws1.Activate
With Worksheets(1).Columns("A")
Set c = .Find(myVal, After:=Range("A65536"),
LookIn:=xlValues, SearchDirection:=xlNext)
If Not c Is Nothing Then
mLoc = c.Address
Workbooks(2).Activate
Workbooks(2).Worksheets(1).Cells(i,
1).EntireRow.Copy
Workbooks(1).Activate
If Not IsEmpty(Range(mLoc).Offset(0,
"Cost Center")) Then
Range(mLoc).Offset(1,
0).EntireRow.Insert
Range(mLoc).Offset(1,
0).EntireRow.Font.ColorIndex = 3
ElseIf IsEmpty(Range(mLoc).Offset(0, 1))
Then
Workbooks(1).Activate

Workbooks(1).Worksheets("Found").Range(mLoc).PasteSpecial Paste:=xlValues
End If
Else
If Is Empty(Range(mLoc),Offset(0, "Cost Center")) Then
Workbooks(2).Activate
Workbooks(2).Worksheets(1).Cells(i,
1).EntireRow.Copy
ws2.Activate
lr2 = Worksheets("Not
Found").Cells(Rows.Count, 1).End(xlUp).Row
Worksheets("Not Found").Cells(lr2 + 1,
1).PasteSpecial Paste:=xlValues
End If
End If
End With
ws3.Activate
Next
Application.CutCopyMode = False
ws1.Activate
Range("$A$1").Activate
End Sub

 

[Guest]

I forgot about the word wrap on the news reader. Here is one you can copy
and paste direct. It has the attenuation subscript so that the lines that
are wrapped will still function.

Dim mRng As Range
Set ws1 = Workbooks(1).Worksheets("Found")
Set ws2 = Workbooks(1).Worksheets("Not Found")
Set ws3 = Workbooks(2).Worksheets("Sheet1")
lr = Cells(Rows.Count, 1).End(xlUp).Row
ws3.Activate
For i = 2 To ws3.Cells(Rows.Count, 1).End(xlUp).Row + 1
myVal = Cells(i, 1).Value
ws1.Activate
With Worksheets(1).Columns("A")
Set c = .Find(myVal, After:=Range("A65536"), _
LookIn:=xlValues, SearchDirection:=xlNext)
If Not c Is Nothing Then
mLoc = c.Address
Workbooks(2).Activate
Workbooks(2).Worksheets(1).Cells(i, _
1).EntireRow.Copy
Workbooks(1).Activate
If Not IsEmpty(Range(mLoc).Offset(0, _
"Cost Center")) Then
Range(mLoc).Offset(1, _
0).EntireRow.Insert
Range(mLoc).Offset(1, _
0).EntireRow.Font.ColorIndex = 3
ElseIf IsEmpty(Range(mLoc).Offset(0, 1)) _
Then
Workbooks(1).Activate

Workbooks(1).Worksheets("Found").Range(mLoc).PasteSpecial Paste:=xlValues
End If
Else
If IsEmpty(Range(mLoc), Offset(0, "Cost Center")) Then _
Workbooks(2).Activate
Workbooks(2).Worksheets(1).Cells(i, _
1).EntireRow.Copy
ws2.Activate
lr2 = Worksheets("NotFound ") _
..Cells(Rows.Count, 1).End(xlUp).Row
Worksheets("Not Found").Cells(lr2 + 1, _
1).PasteSpecial Paste:=xlValues
End If
End If
End With
ws3.Activate
Next
Application.CutCopyMode = False
ws1.Activate
Range("$A$1").Activate
End Sub