comparae column index and cut and copy lines

[sal21]

i have sheet SERVIZIO (is hided) and sheet RATE and sheet DEFINITE...
Is possible to match all line from SERVIZIO to RATE with index in column AC (is unique ID) and recopy the line not found in SERVIZIO into sheet DEFINITE...

In this case the dirrence is 800 line into sheet RATE and 506 lines into SERVIZIO recopy 224 not found line in sheet DEFINITE

the file is here:
http://www2.rapidupload.com/d.php?f...p;filepath=2332

With the first value in column AC of RATE, scanning into column AC of SERVIZIO, the value of RATE not is founded in SERVIZIO, delete this line from RATE and copy into DEFINITE...
With the next value in column AC of RATE, scanning into column AC of SERVIZIO, the value of RATE not is founded in SERVIZIO, delete this line from RATE and copy into DEFINITE...

ecc...

 

[Rijnsent]

Search/cut/paste

Ciao Sal,

try something like this, I tried to give everything some italian names, which makes it hopefully even better understandable for you.

Spero che ti va bene cosi,

Koen

Option Explicit

Sub updaterecords()

Dim inizioRATE As Long
Dim fineRATE As Long
Dim inizioSERVIZIO As Long
Dim fineSERVIZIO As Long
Dim inizioDEFINITE As Long
Dim RATEID As Long
Dim SERVIZIOID As Long
Dim Trovato As Boolean
Dim trov As Long
Dim cerc As Long

'Assuming your data starts at row 2 (row 1 are headers)
inizioRATE = 2
inizioSERVIZIO = 2
inizioDEFINITE = 2

'Find the maximum record on each sheet
fineRATE = Worksheets("RATE").Cells(65536, 29).End(xlUp).Row
fineSERVIZIO = Worksheets("SERVIZIO").Cells(65536, 29).End(xlUp).Row

For trov = inizioRATE To fineRATE
    'First, take the value you'd like to search
    RATEID = Worksheets("RATE").Cells(trov, 29).Value
    Trovato = False
    'Then loop through the SERVIZIO sheet to match
    For cerc = inizioSERVIZIO To fineSERVIZIO
        SERVIZIOID = Worksheets("SERVIZIO").Cells(cerc, 29).Value
        If SERVIZIOID = RATEID Then
            'Found a match
            Trovato = True
            Exit For
        Else
            'No match
        End If
    Next cerc
    
    'Now we know whether a record has been found (Trovato = True) or not
    If Trovato = True Then
        'Found, do nothing
    Else
        'Not found, cut-paste
        Worksheets("RATE").Rows(trov).Cut
        Worksheets("DEFINITE").Paste Destination:=Worksheets("DEFINITE").Rows(inizioDEFINITE)
        inizioDEFINITE = inizioDEFINITE + 1
    End If
Next trov

 

[sal21]

work fine........

... but the line deleted from RATE remain all blank..
Not is possible to add up after the cutting lines...
Tks.

Pizza for you when you come in Napoli.
Note: understand Italine, because my english is very terrible?

 

[Rijnsent]

True, cleaning up to do...

Hi Sal,

I indeed forgot to clean up, adding this to the end of the code (before the End Sub) that should work...

Greetz,

Koen

P.S. Si, capisco e parlo italiano, ma questo e un "forum inglese", per quello rispondo en inglese . Mai stato a Napoli, la mia ex-ragazza era dall norte .

'Finally, clean up the RATE sheet, as there are blank lines
For trov = fineRATE To inizioRATE Step -1
    If IsEmpty(Worksheets("RATE").Cells(trov, 29)) = True Then
        Worksheets("RATE").Rows(trov).Delete Shift:=xlUp
    Else
    End If
Next trov

 

[sal21]

Re: True, cleaning up to do...

Hi Sal,

I indeed forgot to clean up, adding this to the end of the code (before the End Sub) that should work...

Greetz,

Koen

P.S. Si, capisco e parlo italiano, ma questo e un "forum inglese", per quello rispondo en inglese . Mai stato a Napoli, la mia ex-ragazza era dall norte .

'Finally, clean up the RATE sheet, as there are blank lines
For trov = fineRATE To inizioRATE Step -1
    If IsEmpty(Worksheets("RATE").Cells(trov, 29)) = True Then
        Worksheets("RATE").Rows(trov).Delete Shift:=xlUp
    Else
    End If
Next trov

Hi Rijnsent, sorry for delay (have a big prob of stick)and tks for code work fine...
Always on this code, is possible to insert from SERVIZIO all lines not present in sheet RATE?