Column search and comparison against other sheets and viceversa

[tanoMandanga]

Hello folks,

I'm working on a reporting tool that imports a raw file and delivers the information all across the file.
It sorts, arranges, copy and remove rows, but it basically copy/paste procedure.

I was able to figured out the addition of new items and went all the way thru to items being removed and a tracker process.

However I'm having difficulties with rows that are being duplicated and not properly updating (on either adding or removing process).
I've hardcoded the worksheet.count to avoid working outside the range, but still getting issues with others sheets of the same workbook

This is the code for the items being added, the idea behind this is that each sheet name is stored in a column of rawName then reading and cycling thru each row and each sheet, reviewing values from rawName towards the other sheets, if missing then copied and labeled as added.

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:biggrin:" & 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 all sheets values againts rawName, if missing then labeled as removed.

[FONT=inherit]
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
'ws_num = ThisWorkbook.Worksheets.Count

' First initial attempt

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

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:biggrin:" & 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[/FONT]

And this is the comparison process that reads all L column values, copy the row and removes when required.
Cycling thru sheets, reviewing L column values from sheets 4 to 8 that excludes rawdata and 2 more sheets.
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

[FONT=inherit]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")
'ws_num = ThisWorkbook.Worksheets.Count
trkr_date = Format(Date, "[$-en-US]mmmm d, yyyy;@)")
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[/FONT]

Attached is the current work file, with dummy values on all sheets, which after I run the process that calls all subs, several rows get duplicated by the end of it.
I know this is not rocket science, but maybe a fresh look will help me see thru the issues.



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

WorkInProgress.xlsm - Google Drive
https://drive.google.com

 

[tanoMandanga]

For a more explained situacion...

​​​​​​​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.

 

[tanoMandanga]

Sadly I'm having a code that works partially ok, meaning that the code reads and is able to copy some of the needed rows.


Please see code below

Sub CompareNew()
Dim cellName, cellCl As Range
Dim uF, uFS As Long
Dim sName, ClName As String
Dim sDevice, sImported, sTracker As Worksheet


Application.ScreenUpdating = False


Set sImported = Sheets("NIKE-DOC-REP-DEVICE_SERVICETOCI")
uF = sImported.Range("A" & Rows.Count).End(xlUp).Row
Set sTracker = Sheets("Tracking Add-Delete") 'Hoja de tracking
uFT = sTracker.Range("B" & Rows.Count).End(xlUp).Row


For Each cellName In sImported.Range("A2:A" & uF)
sName = cellName
ClName = cellName.Offset(, 3)


Set sDevice = Worksheets(sName)
uFS = sDevice.Range("B" & Rows.Count).End(xlUp).Row


Set cl = sDevice.Range("E5:E" & uFS).Find(ClName, , , lookat:=xlWhole)
    If cl Is Nothing Then
        sDevice.Cells(uFS + 1, 2) = sDevice.Cells(uFS, 2) + 1
        sImported.Activate
        sImported.Range(Cells(cellName.Row, 2), Cells(cellName.Row, 10)).Copy sDevice.Cells(uFS + 1, 3)
        sTracker.Cells(uFT + 1, 2) = Format(Date, "[$-en-US]mmmm d, yyyy;@)") 'El codigo ya empieza a copiar informacion a la hoja de Tracking
        sImported.Cells(cellName.Row, 4).Copy sTracker.Cells(uFT + 1, 3)
        sImported.Cells(cellName.Row, 2).Copy sTracker.Cells(uFT + 1, 4)
        sImported.Cells(cellName.Row, 3).Copy sTracker.Cells(uFT + 1, 5)
        sTracker.Cells(uFT + 1, 6) = "Added"
    Else
    End If
Next cellName


Application.ScreenUpdating = True

This code will read the rows being added from NIKE towards the rest of the workbook and add them if not present, afterwards I will copy them to the tracker sheet (Currently adding all to their respective sheet but not copying'em all to the tracker sheet)


And below is the opposite code..

Sub CompareOld()
Dim cellName, cellCl As Range
Dim uF, uFS As Long
Dim sName, ClName As String
Dim sDevice, sImported, sTracker As Worksheet


Application.ScreenUpdating = False


wsName = Array("WAN Backbone-DC-RoutersSwitches", "Tools Servers", "Backbone Firewall", "Voice Messaging Managed Device", "NGWAN devices")


For i = 0 To UBound(wsName)
    Set sDevice = Worksheets(wsName(i))
    uFS = sDevice.Range("B" & Rows.Count).End(xlUp).Row
    Set sImported = Sheets("NIKE-DOC-REP-DEVICE_SERVICETOCI")
    uF = sImported.Range("A" & Rows.Count).End(xlUp).Row
    Set sTracker = Sheets("Tracking Add-Delete")
    uFT = sTracker.Range("B" & Rows.Count).End(xlUp).Row


    For Each cellName In sDevice.Range("E5:E" & uFS)
        ClName = cellName


        Set cl = sImported.Range("E5:E" & uFS).Find(ClName, , , lookat:=xlWhole)
        If cl Is Nothing Then
            sTracker.Activate
            sTracker.Cells(uFT + 1, 2) = Format(Date, "[$-en-US]mmmm d, yyyy;@)")
            sDevice.Cells(cellName.Row, 5).Copy sTracker.Cells(uFT + 1, 3)
            sDevice.Cells(cellName.Row, 3).Copy sTracker.Cells(uFT + 1, 4)
            sDevice.Cells(cellName.Row, 4).Copy sTracker.Cells(uFT + 1, 5)
            sTracker.Cells(uFT + 1, 6) = "Removed"
            sDevice.Rows(cellName.Row).EntireRow.Delete
        End If
    Next cellName
Next i


Application.ScreenUpdating = True


End Sub

This one will do it backwards, comparing the currently existing rows and if any of them is not present in NIKE sheet will remove it from its current sheet and copy to the tracker sheet. (This is almost not working at all... dunno why!)