PDA

View Full Version : VBA Column comparison against sheet and viceversa



tanoMandanga
01-08-2018, 01:17 PM
Hello folks,


I'm working on a code that validates information on NIKE-DOC-REP-DEVICE_SERVICETOCI sheet against the other sheets.

Basically there are three routines: the first CompareNew, starts on NIKE-DOC-REP-DEVICE_SERVICETOCI, reads A column (sheet destination) and D column value to look up on all remaining sheets of the wbook. If value not found then labeled as added.
The second one CompareOld works against the NIKE-DOC-REP-DEVICE_SERVICETOCI sheet, meaning that will read all E values and trying to find'em on the NIKE-blablabla sheet, if not found labeled as Removed.
The third will simply review all sheets with labels Added or Removed, and copy the reference to the Tracking sheet with some other features.

Reference file, see Module2

Thanks in advance for any tip! And as always, sorry for the trouble...

tanoMandanga
01-08-2018, 01:34 PM
The site was not letting me post the code so I'm pasting the three of them.. .

The one that searchs for new additions


Sub CompareNew()
Dim rawName As Worksheet
Dim lookIn As Range, c As Range, FoundRange As Range
Dim lastrow As Integer, n As Integer
Dim strName As String
Application.ScreenUpdating = False


lastrow = Range("D" & Rows.Count).End(xlUp).Row
Set rawName = ActiveWorkbook.Sheets("NIKE-DOC-REP-DEVICE_SERVICETOCI")


For Each c In rawName.Range("D2:D" & rawName.Range("D" & Rows.Count).End(xlUp).Row)
For i = 2 To lastrow
strName = rawName.Cells(i, 1).Value
Set lookIn = Sheets(strName).Range("E5:E" & Sheets(strName).Range("E" & Rows.Count).End(xlUp).Row)
Set FoundRange = lookIn.Find(what:=c.Value, lookIn:=xlFormulas, lookat:=xlWhole)
If FoundRange Is Nothing Then
rawName.Range("K" & i).Value = "Added"
rawName.Range("B" & i & ":K" & i).Copy Sheets(strName).Range("C" & Rows.Count & ":L" & Rows.Count).End(xlUp).Offset(1)
End If
Next i
Next c
Application.ScreenUpdating = True
End Sub


This is for the items being removed, same as before, sort of reverse engineering, if missing then labeled as removed.


Code:

Sub CompareOld()
Dim i As Variant
Dim rawName As Worksheet
Dim lastrow As Integer
Dim c As Range, lookIn As Range, FoundRange As Range


Application.ScreenUpdating = False


Set rawName = ActiveWorkbook.Sheets("NIKE-DOC-REP-DEVICE_SERVICETOCI")
lastrow = Range("D" & Rows.Count).End(xlUp).Row


For i = 4 To 8
For Each c In Sheets(i).Range("E5:E" & Sheets(i).Range("E" & Rows.Count).End(xlUp).Row)
For iRow = 5 To lastrow
Set lookIn = rawName.Range("D2:D" & rawName.Range("D" & Rows.Count).End(xlUp).Row)
Set FoundRange = lookIn.Find(what:=c.Value, lookIn:=xlFormulas, lookat:=xlWhole)
If FoundRange Is Nothing Then
Worksheets(i).Cells(iRow, "L").Value = "Removed"
End If
Next iRow
Next c
Next i


Application.ScreenUpdating = True
End Sub

tanoMandanga
01-08-2018, 01:35 PM
Finally...

And this is the comparison process that reads all L column values, copy the row and removes when required.
If any "Added" value is found the cells are copied and arranged to the tracker, and the label is cleared.
If any "Removed" is found, then as before the information is copied and the entire row is deleted from source sheet


Code:

Sub TrackerUpdate()
Dim i As Variant
Dim lastrow As Integer
Dim CS As Worksheet, TS As Worksheet, Current As Worksheet


Application.DisplayAlerts = False
Application.StatusBar = True


Set TS = ActiveWorkbook.Sheets("Tracking Add-Delete")
'trkr_date = (this part of the code is not allowing me to post the code so ... blank)
lastrow = Range("B" & Rows.Count).End(xlUp).Row


On Error Resume Next


For i = 4 To 8
For iRow = 5 To lastrow
If Worksheets(i).Cells(iRow, "L").Value = "Added" Then
Worksheets(i).Cells(iRow, "E").Copy Destination:=TS.Range("C" & TS.Rows.Count).End(xlUp).Offset(1)
Worksheets(i).Cells(iRow, "D").Copy Destination:=TS.Range("D" & TS.Rows.Count).End(xlUp).Offset(1)
Worksheets(i).Cells(iRow, "C").Copy Destination:=TS.Range("E" & TS.Rows.Count).End(xlUp).Offset(1)
Worksheets(i).Cells(iRow, "L").Copy Destination:=TS.Range("F" & TS.Rows.Count).End(xlUp).Offset(1)
Worksheets(i).Cells(iRow, "L").Clear
End If
If Worksheets(i).Cells(iRow, "L").Value = "Removed" Then
Worksheets(i).Cells(iRow, "E").Copy Destination:=TS.Range("C" & TS.Rows.Count).End(xlUp).Offset(1)
Worksheets(i).Cells(iRow, "D").Copy Destination:=TS.Range("D" & TS.Rows.Count).End(xlUp).Offset(1)
Worksheets(i).Cells(iRow, "C").Copy Destination:=TS.Range("E" & TS.Rows.Count).End(xlUp).Offset(1)
Worksheets(i).Cells(iRow, "L").Copy Destination:=TS.Range("F" & TS.Rows.Count).End(xlUp).Offset(1)
Worksheets(i).Rows(iRow).EntireRow.Delete
End If
TS.Range("B" & TS.Rows.Count).End(xlUp).Offset(1).Value = trkr_date
Next iRow
Next i


Application.StatusBar = False
Application.DisplayAlerts = True
End Sub