Macro to search, compare, copy and delete
 

Hi everyone,

I am trying to figure out a way to easily do this task.

I have an Excel file containing a list of people. This list is i
"Sheet1"
The headers for each column in this list a
Column A
Dept. Name

Column B
Last Name

Column C
First Name

Column D
Email Address

Column E
Newtork ID

I have another list in "Sheet2"
The headers for each column in this list a
Column A
Name

The names in this column are formatted as "First name space Last Name"
for instance, "John Doe" .

What I want to do is compare the names in Column A on "Sheet2" wit
Column B and Column C in "Sheet1"
If they are the same name, then copy Column A, D and E into "Sheet2
and remove the row containing matching the name in "Sheet1"

Thanks in advance for any help.

Mar

--
Message posted from http://www.ExcelForum.com

Macro to search, compare, copy and delete
 

Suggested is the following:

Sub TransferAndDelete()
Dim Rng1 As Range, Rng2 As Range, Rng3 As Range
Dim C1 As Range, C2 As Range, C3 As Range
Dim FNm As String, LNm As String

With Sheets("Sheet2")
Set Rng1 = .Range("A2:A" & .UsedRange.Rows.Count)
'Next line only necessary if gap in data possible
Set Rng1 = Rng1.SpecialCells(xlCellTypeConstants)
End With
With Sheets("Sheet1")
Set Rng2 = .Range("B2:B" & .UsedRange.Rows.Count)
'Next line only necessary if gap in data possible
Set Rng2 = Rng2.SpecialCells(xlCellTypeConstants)
Set Rng3 = Rng2.Offset(, 1)
End With
For Each C1 In Rng1.Cells
C1 = Trim(C1)
If InStr(2, C1, " ") 0 Then
FNm = Left(C1, InStr(1, C1, " ") - 1)
LNm = Right(C1, Len(C1) - Len(FNm) - 1)
Else
FNm = ""
LNm = ""
End If
For Each C2 In Rng2.Cells
C2 = Trim(C2)
If C2 = LNm Then
Set C3 = C2(1, 2)
If Trim(C3) = FNm Then
C1(1, 2) = C2(1, 0)
C1(1, 3) = C3(1, 2)
C1(1, 4) = C3(1, 3)
C2.EntireRow.EntireRow.Delete
End If
End If
Next
Next
End Sub

Minimal testing done.

Regards,
Greg
(VBA Amateur)

Macro to search, compare, copy and delete
 

Correction to the line:
C2.EntireRow.EntireRow.Delete
Should be
C2.EntireRow.Delete

Don't know how that happened ???

Regards,
Greg
-----Original Message-----
Suggested is the following:

Sub TransferAndDelete()
Dim Rng1 As Range, Rng2 As Range, Rng3 As Range
Dim C1 As Range, C2 As Range, C3 As Range
Dim FNm As String, LNm As String

With Sheets("Sheet2")
Set Rng1 = .Range("A2:A" & .UsedRange.Rows.Count)
'Next line only necessary if gap in data possible
Set Rng1 = Rng1.SpecialCells(xlCellTypeConstants)
End With
With Sheets("Sheet1")
Set Rng2 = .Range("B2:B" & .UsedRange.Rows.Count)
'Next line only necessary if gap in data possible
Set Rng2 = Rng2.SpecialCells(xlCellTypeConstants)
Set Rng3 = Rng2.Offset(, 1)
End With
For Each C1 In Rng1.Cells
C1 = Trim(C1)
If InStr(2, C1, " ") 0 Then
FNm = Left(C1, InStr(1, C1, " ") - 1)
LNm = Right(C1, Len(C1) - Len(FNm) - 1)
Else
FNm = ""
LNm = ""
End If
For Each C2 In Rng2.Cells
C2 = Trim(C2)
If C2 = LNm Then
Set C3 = C2(1, 2)
If Trim(C3) = FNm Then
C1(1, 2) = C2(1, 0)
C1(1, 3) = C3(1, 2)
C1(1, 4) = C3(1, 3)
C2.EntireRow.EntireRow.Delete
End If
End If
Next
Next
End Sub

Minimal testing done.

Regards,
Greg
(VBA Amateur)

.