Excel Data shorting VBA code

”Exact Match
Sub FindMatchAndPastTo3Sheet()

Dim xlRange As Range
Dim xlCell As Range
Dim xlSheet As Worksheet
Dim valueToFind

Count = Sheets(“Sheet1”).Range(“$A:$A”).SpecialCells(xlCellTypeVisible).SpecialCells(xlCellTypeConstants).Count
MsgBox “Sheet1 count =” & Count

Count2 = Sheets(“Sheet2”).Range(“$A:$A”).SpecialCells(xlCellTypeVisible).SpecialCells(xlCellTypeConstants).Count
MsgBox “Sheet2 count =” & Count2

For i = 2 To Count

valueToFind = Sheets(“Sheet1”).Range(“A” & i).Value
‘MsgBox “Sheet 1 Value =” & valueToFind
If valueToFind <> “” Then

Set rWhere = Sheets(“Sheet2”).Range(“A2:A” & Count2) ”Looking values within the range A2 to A13
”Finding exact match:
Set r = rWhere.Find(what:=valueToFind, After:=rWhere(1), LookIn:=xlValues, lookat:=xlWhole, SearchOrder:=xlByRows, _
SearchDirection:=xlNext, _
MatchCase:=False)
If Not r Is Nothing Then
‘MsgBox “Match found =” & r
FirstAddress = r.Address
‘MsgBox “Found in = ” & cellAddress
r.Offset(0, 1).Value = “X” ‘puting x at the right coloumn of the finding cell
”Looping to find multiple values in the sheet2
Do
‘mark the cell in the column to the right if “Ron” is found
r.Offset(0, 1).Value = “X”
Set r = rWhere.FindNext(r)
newRaddress = r.Address
sd = Split(newRaddress, “$”)
‘MsgBox sd(2)
Worksheets(“Sheet2”).Range(newRaddress).Copy Worksheets(“Sheet3”).Range(“B” & sd(2))
Worksheets(“Sheet3”).Range(“C” & sd(2)).Value = r
‘Worksheets(“Sheet3”).Range(“D” & i).Value = sd(1) & sd(2) + 2
Worksheets(“Sheet2”).Range(“C” & sd(2)).Copy Worksheets(“Sheet3”).Range(“E” & sd(2))
Loop While Not r Is Nothing And r.Address <> FirstAddress

‘Range.Copy to other worksheets
Worksheets(“Sheet1”).Range(“A” & i).Copy Worksheets(“Sheet3”).Range(“A” & i)
‘Worksheets(“Sheet2”).Range(r.Address).Copy Worksheets(“Sheet3”).Range(“B” & i)
‘Worksheets(“Sheet3”).Range(“C” & i).Value = r
End If
End If
Next

End Sub

Leave a Reply