conservare nomi che saranno cancellati

Hai un problema con Excel?

Nuova discussione

conservare nomi che saranno cancellati
di niko (utente non iscritto) data: 25/07/2014 13:57:47
Mi servirebbe un aiuto a fare un codice.
Devo copiare dei nomi da un foglio excel 2002 denominato “stampa movimenti” i cognomi iniziano da k3 e i nomi da L3.
Questi nominativi devono essere copiati in un foglio chiamato “usciti” dello stesso file a partire da A5000 e uniti in un'unica cella non separati come nel foglio dove li copia.
Da precisare è che nel foglio “stampa movimenti” i nominativi ogni giorno vengono cancellati e riscritti e possono essere un numero sempre variabile in pratica questi nomi che vengono cancellati li devo conservare nel foglio “usciti”.
Per quando riguarda il file è terminato manca solo quest’ultimo codice che va inserito in quello sotto all’inizio dopo “sub avvia”

Codice:
Option Explicit
Public sh1 As Worksheet, sh2 As Worksheet, x As Long, y As Long, z As Long

Sub avvia()
Sheets("stampa movimenti").Select 'copia i movimenti del giorno prima per lasciarti una copia in caso servisse
Range("A3:N2489").Select
Selection.Copy
ActiveWindow.SmallScroll ToRight:=10
Range("S3").Select
ActiveSheet.Paste
Range("K1:L1").Select
Sheets("presenti").Select
Range("A2").Select ' aggiorna dati esterni del foglio presenti
Selection.QueryTable.Refresh BackgroundQuery:=False
Range("E2").Select
Selection.QueryTable.Refresh BackgroundQuery:=False
Range("I2").Select
Selection.QueryTable.Refresh BackgroundQuery:=False
Range("M2").Select
Selection.QueryTable.Refresh BackgroundQuery:=False
Range("Q2").Select
Selection.QueryTable.Refresh BackgroundQuery:=False
Range("U2").Select
Selection.QueryTable.Refresh BackgroundQuery:=False
Range("Y2").Select
Selection.QueryTable.Refresh BackgroundQuery:=False
Range("AC2").Select
Selection.QueryTable.Refresh BackgroundQuery:=False
Range("AG2").Select
Selection.QueryTable.Refresh BackgroundQuery:=False
Range("AK2").Select
Selection.QueryTable.Refresh BackgroundQuery:=False
Range("AO2").Select
Selection.QueryTable.Refresh BackgroundQuery:=False
Range("AS2").Select
Selection.QueryTable.Refresh BackgroundQuery:=False
Range("AW2").Select
Selection.QueryTable.Refresh BackgroundQuery:=False
Range("BA2").Select
Selection.QueryTable.Refresh BackgroundQuery:=False
Range("BE2").Select
Selection.QueryTable.Refresh BackgroundQuery:=False
Range("BI2").Select
Selection.QueryTable.Refresh BackgroundQuery:=False
Range("BM2").Select
Selection.QueryTable.Refresh BackgroundQuery:=False
Range("BQ2").Select
Selection.QueryTable.Refresh BackgroundQuery:=False
Range("BU2").Select
Selection.QueryTable.Refresh BackgroundQuery:=False
Range("BY2").Select
Selection.QueryTable.Refresh BackgroundQuery:=False
Range("CC2").Select
Selection.QueryTable.Refresh BackgroundQuery:=False
Range("CG2").Select
Selection.QueryTable.Refresh BackgroundQuery:=False
Range("CK2").Select
Selection.QueryTable.Refresh BackgroundQuery:=False
Range("CO2").Select
Selection.QueryTable.Refresh BackgroundQuery:=False
Range("CS2").Select
Selection.QueryTable.Refresh BackgroundQuery:=False
Range("Cw2").Select
Selection.QueryTable.Refresh BackgroundQuery:=False
Range("da2").Select
Selection.QueryTable.Refresh BackgroundQuery:=False
Range("de2").Select
Selection.QueryTable.Refresh BackgroundQuery:=False
Range("di2").Select
Selection.QueryTable.Refresh BackgroundQuery:=False
Range("dm2").Select
Selection.QueryTable.Refresh BackgroundQuery:=False
Range("dq2").Select
Selection.QueryTable.Refresh BackgroundQuery:=False
Range("du2").Select
Selection.QueryTable.Refresh BackgroundQuery:=False
Range("dy2").Select
Selection.QueryTable.Refresh BackgroundQuery:=False

'Sheets("usciti").Select ' aggiorna il foglio usciti
' Range("a2").Select
' Selection.QueryTable.Refresh BackgroundQuery:=False
' Range("f2").Select
' Selection.QueryTable.Refresh BackgroundQuery:=False

Sheets("I").Select ' seleziona A5-B5-C5 di tutte le sezioni e trascina giu per eliminare errori
Range("A5:C5").Select
Selection.AutoFill Destination:=Range("A5:C92"), Type:=xlFillDefault
Range("A5:C92").Select
Sheets("II").Select
Range("A5:C5").Select
Selection.AutoFill Destination:=Range("A5:C92"), Type:=xlFillDefault
Range("A5:C92").Select
Sheets("III").Select
Range("A5:C5").Select
Selection.AutoFill Destination:=Range("A5:C92"), Type:=xlFillDefault
Range("A5:C92").Select
Sheets("IV").Select
Range("A5:C5").Select
Selection.AutoFill Destination:=Range("A5:C92"), Type:=xlFillDefault
Range("A5:C92").Select
Sheets("V").Select
Range("A5:C5").Select
Selection.AutoFill Destination:=Range("A5:C92"), Type:=xlFillDefault
Range("A5:C92").Select
Sheets("VI").Select
Range("A5:C5").Select
Selection.AutoFill Destination:=Range("A5:C92"), Type:=xlFillDefault
Range("A5:C92").Select
Sheets("VII").Select
Range("A5:C5").Select
Selection.AutoFill Destination:=Range("A5:C92"), Type:=xlFillDefault
Range("A5:C92").Select
Sheets("VIII").Select
Range("A5:C5").Select
Selection.AutoFill Destination:=Range("A5:C92"), Type:=xlFillDefault
Range("A5:C92").Select
Sheets("IX").Select
Range("A5:C5").Select
Selection.AutoFill Destination:=Range("A5:C89"), Type:=xlFillDefault
Range("A5:C89").Select
Sheets("X").Select
Range("A5:C5").Select
Selection.AutoFill Destination:=Range("A5:C90"), Type:=xlFillDefault
Range("A5:C90").Select
Sheets("XI").Select
Range("A5:C5").Select
Selection.AutoFill Destination:=Range("A5:C89"), Type:=xlFillDefault
Range("A5:C89").Select
Sheets("XII").Select
Range("A5:C5").Select
Selection.AutoFill Destination:=Range("A5:C89"), Type:=xlFillDefault
Range("A5:C89").Select
Sheets("XIII").Select
Range("A5:C5").Select
Selection.AutoFill Destination:=Range("A5:C89"), Type:=xlFillDefault
Range("A5:C89").Select

Sheets("C.CL.").Select
Range("A5:C5").Select
Selection.AutoFill Destination:=Range("A5:C50"), Type:=xlFillDefault
Range("A5:C50").Select
Range("A51:C51").Select
Selection.AutoFill Destination:=Range("A51:C70"), Type:=xlFillDefault
Range("A51:C70").Select
Range("A71:C71").Select
Selection.AutoFill Destination:=Range("A71:C120"), Type:=xlFillDefault
Range("A71:C120").Select
Range("A121:C121").Select
Selection.AutoFill Destination:=Range("A121:C140"), Type:=xlFillDefault
Range("A121:C140").Select
Range("A141:C141").Select
Selection.AutoFill Destination:=Range("A141:C150"), Type:=xlFillDefault
Range("A141:C150").Select
Range("A151:C151").Select
Selection.AutoFill Destination:=Range("A151:C170"), Type:=xlFillDefault
Range("A151:C170").Select
Range("A171:C171").Select
Selection.AutoFill Destination:=Range("A171:C210"), Type:=xlFillDefault
Range("A171:C210").Select
Range("A211:C211").Select
Selection.AutoFill Destination:=Range("A211:C240"), Type:=xlFillDefault
Range("A211:C240").Select
Range("A345:C345").Select
Selection.AutoFill Destination:=Range("A345:C466"), Type:=xlFillDefault
Range("A345:C466").Select
Range("A347:C347").Select
Selection.AutoFill Destination:=Range("A347:C497"), Type:=xlFillDefault
Range("A347:C497").Select
Range("A498:C498").Select
Selection.AutoFill Destination:=Range("A498:C599"), Type:=xlFillDefault
Range("A498:C599").Select
Range("A600:C600").Select
Selection.AutoFill Destination:=Range("A600:C699"), Type:=xlFillDefault
Range("A600:C699").Select
Range("A700:C700").Select
Selection.AutoFill Destination:=Range("A700:C739"), Type:=xlFillDefault
Range("A700:C739").Select
Range("A740:C740").Select
Selection.AutoFill Destination:=Range("A740:C769"), Type:=xlFillDefault
Range("A740:C769").Select
Range("A770:C770").Select
Selection.AutoFill Destination:=Range("A770:C800"), Type:=xlFillDefault
Range("A770:C800").Select
Range("a801:C801").Select
Selection.AutoFill Destination:=Range("A801:C810"), Type:=xlFillDefault
Range("A801:C810").Select
Range("a811:C811").Select
Selection.AutoFill Destination:=Range("A811:C830"), Type:=xlFillDefault
Range("A811:C830").Select
Range("a831:C831").Select
Selection.AutoFill Destination:=Range("A831:C850"), Type:=xlFillDefault
Range("A831:C850").Select

Sheets("Transex").Select
Range("A5:C5").Select
Selection.AutoFill Destination:=Range("A5:C32"), Type:=xlFillDefault
Range("A5:C32").Select
Sheets("TR1").Select
Range("A5:C5").Select
Selection.AutoFill Destination:=Range("A5:C61"), Type:=xlFillDefault
Range("A5:C61").Select
Sheets("TR2").Select
Range("A5:D5").Select
Selection.AutoFill Destination:=Range("A5:D34"), Type:=xlFillDefault
Range("A5:D34").Select

Dim r As Long 'controlla i cambiamenti tra foglio"archivio" e tutti i fogli delle sezioni
Dim rr As Long
Dim G As Long
Dim K As Long
Dim l As Variant
Dim n As String
Dim p As Variant
Dim nn As Variant
Dim rg As Long
Dim trovato As Boolean
Dim dat(1 To 3)
Set sh1 = Worksheets("Archivio")
sh1.Activate
Application.EnableEvents = False
rg = Cells(Rows.Count, 15).End(xlUp).Row + 1
Range(Cells(3, 5), Cells(rg, 6)).ClearContents
Range(Cells(3, 15), Cells(rg, 15)).ClearContents
G = Cells(Rows.Count, 7).End(xlUp).Row + 1
Range(Cells(3, 7), Cells(G, 10)).ClearContents
K = Cells(Rows.Count, 11).End(xlUp).Row + 1
Range(Cells(3, 11), Cells(K, 14)).ClearContents
'Application.ScreenUpdating = False''non fa vedere i passaggi dei controlli sezione per sezione se togli le virgolette lo attivi'
G = 3
K = 3
For x = 1 To 18
Sheets(x).Select
rg = Cells(Rows.Count, 1).End(xlUp).Row
n = Sheets(x).Name
Set sh2 = Worksheets(n)
Select Case n
Case "I": p = 1 'assegna alla sezione il numero normale anzichè il numero romano'
Case "II": p = 2
Case "III": p = 3
Case "IV": p = 4
Case "V": p = 5
Case "VI": p = 6
Case "VII": p = 7
Case "VIII": p = 8
Case "IX": p = 9
Case "X": p = 10
Case "XI": p = 11
Case "XII": p = 12
Case "XIII": p = 13
Case "Transex": p = "D"
Case "TR1": p = "TR1"
Case "TR2": p = "TR2"
Case "FEMMINILE": p = "F"
End Select
For y = 5 To rg
If Cells(y, 2) = "" Or Cells(y, 2) = 0 Then
GoTo 10
Else
If Cells(y, 1) <> "" Then
If n = "C.CL." Then 'nel foglio centro clinico...'
Select Case y
Case 5 To 50: p = "DEG." 'le celle da 5 a 50 è reparto DEG'
Case 51 To 70: p = "OSS."
Case 71 To 120: p = "EXD."
Case 121 To 140: p = "I.S."
Case 141 To 150: p = "M"
Case 151 To 170: p = "FXG"
Case 171 To 210: p = "PER"
Case 211 To 240: p = "R.O."
Case 241 To 290: p = "nota"
Case 291 To 344: p = "ITO"
Case 345 To 497: p = "?"
Case 498 To 599: p = "GIU"
Case 600 To 699: p = "PEN"
Case 700 To 739: p = "CCC"
Case 740 To 769: p = "K"
Case 770 To 800: p = "NIDO"
Case 801 To 810: p = "FXGF"
Case 811 To 830: p = "PF"
Case 831 To 850: p = "ROF"
End Select
End If
If IsNumeric(Cells(y, 1)) Then l = Val(Cells(y, 1)) Else l = Cells(y, 1)
End If
dat(1) = l
dat(2) = Cells(y, 2)
dat(3) = Cells(y, 3)
End If
rr = sh1.Cells(Rows.Count, 1).End(xlUp).Row
For z = 2 To rr
If sh1.Cells(z, 1) = dat(2) And sh1.Cells(z, 2) = dat(3) Then trovato = True: r = z: Exit For
Next z
If trovato = True Then
If sh1.Cells(r, 3) = p And sh1.Cells(r, 4) = dat(1) Then
sh1.Cells(r, 15) = 1
Else
sh1.Cells(r, 5) = p
sh1.Cells(r, 6) = dat(1)
sh1.Cells(r, 15) = 1
End If
End If
If trovato = False Then
r = rr + 1
sh1.Cells(r, 1) = dat(2)
sh1.Cells(r, 2) = dat(3)
sh1.Cells(r, 3) = p
sh1.Cells(r, 4) = dat(1)
sh1.Cells(G, 7) = dat(2)
sh1.Cells(G, 8) = dat(3)
sh1.Cells(G, 9) = p
sh1.Cells(G, 10) = dat(1)
sh1.Cells(r, 15) = 0
G = G + 1
End If
trovato = False
10:
Next y
Next x
sh1.Activate
r = Cells(Rows.Count, 15).End(xlUp).Row
For x = 3 To r
If x = r Then Exit For
If Cells(x, 15) = "" Then
Cells(K, 11) = Cells(x, 1)
Cells(K, 12) = Cells(x, 2)
Cells(K, 13) = Cells(x, 3)
Cells(K, 14) = Cells(x, 4)
Range(Cells(x, 1), Cells(x, 6)).Select
Selection.Delete Shift:=xlUp
Cells(x, 15).Select
Selection.Delete Shift:=xlUp
x = x - 1
r = r - 1
K = K + 1
End If
Next x
Range("A2:F2").Select
Range(Selection, Selection.End(xlDown)).Select
Selection.Sort Key1:=Range("E3"), Order1:=xlAscending, Key2:=Range("A3") _
, Order2:=xlAscending, Header:=xlGuess, OrderCustom:=1, MatchCase:= _
False, Orientation:=xlTopToBottom, DataOption1:=xlSortNormal, DataOption2 _
:=xlSortNormal
r = Cells(Rows.Count, 5).End(xlUp).Row
Range("A2:F" & r).Select ' ordia alfabetico i movimenti'
Selection.Sort Key1:=Range("A3"), Order1:=xlAscending, Header:=xlYes, _
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
DataOption1:=xlSortNormal
Range("G2:J2").Select 'ordina alfabetico gli entrati'
Range(Selection, Selection.End(xlDown)).Select
Selection.Sort Key1:=Range("G3"), Order1:=xlAscending, Header:=xlYes, _
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
DataOption1:=xlSortNormal
Range("k2:N2").Select 'ordina alfabetico gli usciti'
Range(Selection, Selection.End(xlDown)).Select
Selection.Sort Key1:=Range("K3"), Order1:=xlAscending, Header:=xlYes, _
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
DataOption1:=xlSortNormal
Range("A3").Select
Application.EnableEvents = True
Application.ScreenUpdating = True
Sheets("archivio").Select

Application.DisplayAlerts = False ' copia i nominativi dal foglio archivio al fogli stampa i moviment
Sheets("archivio").Select
Range("A1:r400").Select
Application.CutCopyMode = False
Selection.Copy
Sheets("stampa movimenti").Select
Range("A1:B1").Select
ActiveSheet.Paste
Application.DisplayAlerts = True
Range("A1:R972").Select
Application.CutCopyMode = False
Selection.Interior.ColorIndex = xlNone

'Sub sta1()
Dim rt As Long
Dim r1 As Long
Dim st As String
Dim cp As Long
Dim d As Long
Dim ind As Variant
Dim rrt As Long
Dim rrtt As Long
Dim rrttt As Long
Dim rrrt As Long
'ELIMINA GLI ENTRATI E GLI USCITI CHE VENGONO RINOMINATI PERCHE' IL NOME SBAGLIATO E FINISCE A FINE 7
Dim Gt As Range, KK As Range, cl3 As Object, cl4 As Object, _
xx As Long, yy As Long, zt As Long, xt As Long, _
yt As Long, zz As Long, xtt As Long, xttt As Long, xXtt As Long
Set Gt = Range("G3:G1500")
Set KK = Range("K3:K1500")
'mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm
'AMMETTENDO CHE LA RIGA 1 è OCCUPATA DALLE INTESTAZIONI DI COLONNA
'EFFETTUO UN CICLO PER TROVARE LA PRIMA CELLA OCCUPATA DELLA COLONNA G;
'IN OGNI CASO PUOI MODIFICARE IL RANGE G e K EDITANDO LE VARIABILI SOPRA (Set)
For Each cl3 In Gt
If cl3 = "" Then
cl3.Select
xt = Selection.Row
Exit For
'If cl3 <> "" Then
Else
cl3.Select
xt = Selection.Row
'xt è IL NUMERO RIGA DELLA PRIMA CELLA OCCUPATA DELLA COLONNA G
Exit For
End If
Next
If cl3 = "" Then
yt = Cells(1500, 7).End(xlUp).Row + 1
Else
yt = Cells(1500, 7).End(xlUp).Row
End If
'yt è IL NUMERO RIGA DELL'ULTIMA CELLA OCCUPATA DELLA COLONNA G
'mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm
'EFFETTUO UN CICLO PER TROVARE LA PRIMA CELLA OCCUPATA DELLA COLONNA K
For Each cl4 In KK
If cl4 = "" Then
cl4.Select
xx = Selection.Row
Exit For
'If cl4 <> "" Then
Else
cl4.Select
xx = Selection.Row
'xx è IL NUMERO RIGA DELLA PRIMA CELLA OCCUPATA DELLA COLONNA K
Exit For
End If
Next
If cl4 = "" Then
yy = Cells(1500, 11).End(xlUp).Row + 1
Else
yy = Cells(1500, 11).End(xlUp).Row
End If
'yy è IL NUMERO RIGA DELL'ULTIMA CELLA OCCUPATA DELLA COLONNA K
'mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm
'DOPPIO CICLO FOR/NEXT PER CONTROLLARE OGNI RIGA OCCUPATA DELLE
'COLONNE G-H-I-J CON OGNI RIGA OCCUPATA DELLE COLONNE K-L-M-N
For zt = xt To yt
For zz = xx To yy
If Cells(zt, 9) = Cells(zz, 13) And Cells(zt, 10) = Cells(zz, 14) _
And (Cells(zt, 7) = Cells(zz, 11) Or Cells(zt, 8) = Cells(zz, 12)) Then
Range(Cells(zt, 7), Cells(zt, 10)).ClearContents
Range(Cells(zz, 11), Cells(zz, 14)).ClearContents
End If
Next zz
Next zt
'FINE 7

Dim cl, cl2, rng, RNG2, NOME, COGNOME ' CANCELLA I CAMBIAMENTI DI CELLA DEL CCL TR1 TR2 F D IL CODICE FINISCE DOV'è SCRITTO FINE2
rt = Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
Dim Condizioni As New Collection
Condizioni.Add "F|F"
Condizioni.Add "K|K"
Condizioni.Add "K|NIDO"
Condizioni.Add "K|PEN"
Condizioni.Add "K|GIU"
Condizioni.Add "K|CCC"
Condizioni.Add "NIDO|NIDO"
Condizioni.Add "NIDO|PEN"
Condizioni.Add "NIDO|GIU"
Condizioni.Add "NIDO|K"
Condizioni.Add "NIDO|CCC"
Condizioni.Add "PEN|PEN"
Condizioni.Add "PEN|K"
Condizioni.Add "PEN|NIDO"
Condizioni.Add "PEN|GIU"
Condizioni.Add "PEN|CCC"
Condizioni.Add "GIU|GIU"
Condizioni.Add "GIU|K"
Condizioni.Add "GIU|NIDO"
Condizioni.Add "GIU|PEN"
Condizioni.Add "GIU|CCC"
Condizioni.Add "CCC|CCC"
Condizioni.Add "CCC|K"
Condizioni.Add "CCC|NIDO"
Condizioni.Add "CCC|PEN"
Condizioni.Add "CCC|GIU"
Condizioni.Add "D|D"
Condizioni.Add "TR1|TR1"
Condizioni.Add "TR2|TR2"
'Condizioni.Add "TR2|TR1"
'Condizioni.Add "TR1|TR2"
Condizioni.Add "OSS.|OSS."
Condizioni.Add "I.S.|I.S."
Condizioni.Add "EXD.|EXD."
Condizioni.Add "DEG.|DEG."
Condizioni.Add "DEG.|OSS."
Condizioni.Add "DEG.|EXD."
Condizioni.Add "DEG.|I.S."
Condizioni.Add "OSS.|EXD."
Condizioni.Add "OSS.|I.S."
Condizioni.Add "OSS.|DEG."
Condizioni.Add "EXD.|DEG."
Condizioni.Add "EXD.|OSS."
Condizioni.Add "EXD.|I.S."
Condizioni.Add "I.S.|EXD."
Condizioni.Add "I.S.|OSS."
Condizioni.Add "I.S.|DEG."
ReDim c(rt) As Integer
Dim I, j, Kt, cond
Set RNG2 = Range("C3:E" & rt)
For Each cl2 In RNG2
For Each cond In Condizioni
If cl2.Offset(0, 0) = Split(cond, "|")(0) And cl2.Offset(0, 2) = Split(cond, "|")(1) Then
I = I + 1
c(I) = cl2.Row
End If
Next
Next
Kt = I
Sheets("stampa movimenti").Select
For I = 1 To Kt
ActiveSheet.Range("A1:F1").Offset(c(I) - 1, 0).Delete
For j = I + 1 To Kt
c(j) = c(j) - 1
Next
Next 'FINE2

rrt = Range("I" & Rows.Count).End(xlUp).Row 'cancella nella colonna entrati il femminile tr1 e tr2 il codice finisce a fine 6
For xt = 3 To rrt
If Cells(xt, "I") = "F" Or Cells(xt, "I") = "FXG" Or Cells(xt, "I") = "FXGF" Or Cells(xt, "I") = "TR1" Or Cells(xt, "I") = "TR2" Or Cells(xt, "I") = "GIU" Or Cells(xt, "I") = "PEN" Or Cells(xt, "I") = "CCC" Or Cells(xt, "I") = "NIDO" Or Cells(xt, "I") = "K" Or Cells(xt, "I") = "?" Then
Range("G" & xt & ":" & "J" & xt).ClearContents
End If
Next xt 'fine 5

rrtt = Range("E" & Rows.Count).End(xlUp).Row 'cancella nella colonna movimenti i fuori per giustizia i detenuti da prendere in carico(?)i permessi e ricovero finisce a fine 6
For xtt = 3 To rrtt
If Cells(xtt, "E") = "PER" Or Cells(xtt, "E") = "FXG" Or Cells(xtt, "I") = "FXGF" Or Cells(xtt, "E") = "R.O." Or Cells(xtt, "E") = "GIU" Or Cells(xtt, "E") = "PEN" Or Cells(xtt, "E") = "CCC" Or Cells(xtt, "E") = "NIDO" Or Cells(xtt, "E") = "K" Then
Range("A" & xtt & ":" & "F" & xtt).ClearContents
End If
Next xtt
rrttt = Range("C" & Rows.Count).End(xlUp).Row
For xttt = 3 To rrttt
If Cells(xttt, "C") = "PER" Or Cells(xttt, "C") = "FXG" Or Cells(xttt, "I") = "FXGF" Or Cells(xttt, "C") = "R.O." Or Cells(xttt, "C") = "GIU" Or Cells(xttt, "C") = "PEN" Or Cells(xttt, "C") = "CCC" Or Cells(xttt, "C") = "NIDO" Or Cells(xttt, "C") = "K" Then
Range("A" & xttt & ":" & "F" & xttt).ClearContents
End If
Next xttt

rrrt = Range("M" & Rows.Count).End(xlUp).Row 'cancella nella colonna usciti
For xXtt = 3 To rrrt
If Cells(xXtt, "M") = "?" Or Cells(xXtt, "M") = "F" Or Cells(xXtt, "M") = "NIDO" Or Cells(xXtt, "M") = "GIU" Or Cells(xXtt, "M") = "PEN" Or Cells(xXtt, "M") = "K" Or Cells(xXtt, "M") = "CCC" Then
Range("K" & xXtt & ":" & "N" & xXtt).ClearContents
End If
Next xXtt 'fine 6

Range("A3:F" & rt).Select 'ordina alfabetico colonna movimenti
Selection.Sort Key1:=Range("E3"), Order1:=xlAscending, Header:=xlGuess, _
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
DataOption1:=xlSortNormal
Range("G3:J1700").Select 'ordina alfabetico colonna entrati
Selection.Sort Key1:=Range("G3"), Order1:=xlAscending, Header:=xlGuess, _
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
DataOption1:=xlSortNormal
Range("K3:N1700").Select ' ordina alfabetico colonna usciti
Selection.Sort Key1:=Range("K3"), Order1:=xlAscending, Header:=xlGuess, _
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
DataOption1:=xlSortNormal
Range("G8").Select
Set sh1 = Worksheets("stampa movimenti")
sh1.Activate
Application.ScreenUpdating = False
st = Cells(2, 16)
cp = Cells(2, 17)
Cells(1, 18) = Cells(Rows.Count, 5).End(xlUp).Row
r1 = Cells(1, 18)
Cells(1, 19) = Cells(Rows.Count, 7).End(xlUp).Row
Cells(1, 20) = Cells(Rows.Count, 11).End(xlUp).Row
Cells(2, 18).Select
ActiveCell.FormulaR1C1 = "=LARGE(R[-1]C:R[-1]C[2],1)"
rt = Cells(2, 18)
Range(Cells(1, 18), Cells(2, 20)).ClearContents
If r1 < rt Then
If r1 = 2 Then
Range(Cells(r1 + 1, 1), Cells(rt, 4)).Select
Selection.Insert Shift:=xlDown
Cells(4, 5).Copy
Range(Cells(r1 + 1, 1), Cells(rt, 4)).Select
ActiveSheet.Paste
Application.CutCopyMode = False
Else
Range(Cells(r1 + 1, 1), Cells(rt, 6)).Select
Selection.Insert Shift:=xlDown
End If
End If
If r1 < rt Then d = rt Else d = r1
Range("A3:F" & d).Select
Selection.Sort Key1:=Range("A3"), Order1:=xlAscending, Header:=xlGuess
For xt = 3 To d Step 2
Range(Cells(xt, 1), Cells(xt, 14)).Interior.ColorIndex = 45 ' colora di arancione un rigo si e uno no
Next xt
'Range("A3:N" & r).Select 'seleziona l'area di stampa'
'ind = Range("A3:N" & rt).Address
'ActiveSheet.PageSetup.PrintArea = ind
'With ActiveSheet.PageSetup
' .PrintTitleRows = "$1:$2"
' .PrintTitleColumns = ""
'End With
'With ActiveSheet.PageSetup
' .LeftHeader = " &D - &T &P/&N" 'stampa data ora e numero di pagine'
' .CenterHeader = "" & Chr(10) & "" & Chr(10) & "" & Chr(10) & "" & Chr(10) & "" & Chr(10) & _
' "&""Arial""&12U F F I C I O P O S T A&""Arial,Normale""&10" & Chr(10) & _
'"&""Arial""&12" 'intestazione pagina'
' .LeftMargin = Application.InchesToPoints(0.1) 'margine sinistro della stampa'
' .RightMargin = Application.InchesToPoints(0.1) 'margine destro'
' .TopMargin = Application.InchesToPoints(1.6) 'margine alto'
' .BottomMargin = Application.InchesToPoints(0.25) 'adatta lo scritto alla pagina della stampa'
' .HeaderMargin = Application.InchesToPoints(0.1) 'abbassa o alza il titolo della pagina di stampa'
' .FooterMargin = Application.InchesToPoints(0.2) 'abbassa o alza lo scritto sotto la pagine'
' .PrintHeadings = False
' .PrintGridlines = False
' .PrintComments = xlPrintNoComments
' .CenterHorizontally = False
' .CenterVertically = False ' .Orientation = xlLandscape 'stampa in verticale...per stampare in orizzontale sostituisci con =x1portrait'
' .Draft = False
' .PaperSize = xlPaperA4 'tipo di foglio usati per la stampa'
' .FirstPageNumber = xlAutomatic
' .Order = xlDownThenOver
' .BlackAndWhite = False
' .Zoom = 100 'ingrandisce o rimpiccolisce la stampa'
' .PrintErrors = xlPrintErrorsDisplayed
'End With
'Application.ScreenUpdating = True
'If st = "V" Then ActiveWindow.SelectedSheets.PrintPreview
'If st = "S" Then ActiveWindow.SelectedSheets.PrintOut Copies:=cp
If r1 < rt Then
Range(Cells(r1 + 1, 1), Cells(rt, 4)).Select
Selection.Delete Shift:=xlUp
End If
Cells(2, 1).Select
Sheets("archivio").Select

'Sub aggiorna1() 'aggiorna i nominativi, movimenti, entrati e usciti
Dim Gh As Long
Dim Kh As Long
Set sh1 = Worksheets("Archivio")
sh1.Activate
Gh = Cells(Rows.Count, 7).End(xlUp).Row + 1
Range(Cells(3, 7), Cells(Gh, 10)).ClearContents
Kh = Cells(Rows.Count, 11).End(xlUp).Row + 1
Range(Cells(3, 11), Cells(Kh, 14)).ClearContents
For x = 3 To Cells(Rows.Count, 1).End(xlUp).Row
If Cells(x, 5) <> "" Then
Cells(x, 3) = Cells(x, 5)
Cells(x, 4) = Cells(x, 6)
Cells(x, 5) = ""
Cells(x, 6) = ""
End If
Next x
Cells(2, 1).Select
Range("A3:F1516").Select 'ordina alfabetico tutti i nomi'
Selection.Sort Key1:=Range("A3"), Order1:=xlAscending, Header:=xlGuess, _
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
DataOption1:=xlSortNormal
Sheets("Archivio").Select
Range("AB3").Select
Selection.AutoFill Destination:=Range("AB3:AB247"), Type:=xlFillDefault
Range("AB3:AB247").Select
ActiveWorkbook.Save
Application.Run "'rubricagedet.xls'!trova1"
Range("B9").Select
End Sub

Sub trova1() 'rende visibile la finestra per cercare i nomi
If userform1.Visible = False Then userform1.Show False
userform1.Left = 345 'coordinate dove far apparire la finestra destra sinistra
userform1.Top = 200
End Sub

allego due file come esempio..
il file "primo giorno" ha copiato i nomi dal foglio "stampa movimenti" al foglio "usciti"...il file "giorno successico" ha copiato nomi nuovi sempre nello stesso modo ma senza cancellare i nomi del giorno precedente.
non so se
www.filedropper.com/primogiorno
clicca sul link poi su download this file poi inserisci le lettere che compaiono e scarica
dropcanvas.com/in73d
qui clikki direttamente sul file per scaricare.
il primo sito non mi permette di caricare un secondo file e allora ho fatto con un altro sito.
GRAZIE
di niko (utente non iscritto) data: 27/07/2014 16:05:09
ok ho risolto cosi
Sub Copia_e_Cancella()
Dim ws1 As Worksheet
Dim ws2 As Worksheet
Dim ultK As Long
Dim ultA As Long
Dim iRiga As Long

Set ws1 = Foglio11 'stampa movimenti
Set ws2 = Foglio21 'usciti

ultK = IIf(ws1.Range("K3").Value = "", 3, ws1.Range("K" & Rows.Count).End(xlUp).Row)
ultA = IIf(ws2.Range("A5000").Value = "", 5000, ws2.Range("A" & Rows.Count).End(xlUp).Row + 1)

Application.EnableEvents = False
If ultK > 2 Then
For iRiga = 3 To ultK
ws2.Range("A" & ultA).Value = ws1.Range("K" & iRiga).Value & " " & ws1.Range("L" & iRiga).Value
ultA = ultA + 1
Next iRiga
End If

'CANCELLO I NOMI DAL FOGLIO "stampa movimenti"
ws1.Range("K3:L" & ultK).ClearContents 'SE VUOI ESCLUDERLA, METTICI UN APICE DAVANTI O ELIMINALA
Application.EnableEvents = True

Set ws1 = Nothing
Set ws2 = Nothing
End Sub

Vuoi Approfondire?