di trittico69 » 04/03/11 13:26
Sub sta1()
Dim r As Long
Dim r1 As Long
Dim st As String
Dim cp As Long
Dim d As Long
Dim ind As Variant
Dim rr As Long
Dim cl, CL2, RNG, RNG2, NOME, COGNOME ' CANCELLA I CAMBIAMENTI DI CELLA DEL CCL TR1 TR2 F D IL CODICE FINISCE DOV'è SCRITTO FINE2
r = Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
Dim Condizioni As New Collection
Condizioni.Add "F|F"
Condizioni.Add "D|D"
Condizioni.Add "TR1|TR1"
Condizioni.Add "TR2|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(r) As Integer
Dim i, j, k, cond
Set RNG2 = Range("C3:E" & r)
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
k = i
Sheets("ARCHIVIO").Select
For i = 1 To k
ActiveSheet.Range("A1:F1").Offset(c(i) - 1, 0).Delete
For j = i + 1 To k
c(j) = c(j) - 1
Next
Next 'FINE2
rr = Range("I" & Rows.Count).End(xlUp).Row 'cancella nella colonna entrati il femminile tr1 e tr2 il codice finisce a fine 5
For X = 3 To rr
If Cells(X, "I") = "F" Or Cells(X, "I") = "TR1" Or Cells(X, "I") = "TR2" Then
Range("G" & X & ":" & "J" & X).ClearContents
End If
Next X 'fine 5
Range("A3:F" & r).Select 'ordina alfabetico colonna movimenti
Selection.Sort Key1:=Range("E3"), Order1:=xlAscending, Header:=xlGuess, _
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
DataOption1:=xlSortNormal
Range("G3:J170").Select 'ordina alfabetico colonna entrati
Selection.Sort Key1:=Range("G3"), Order1:=xlAscending, Header:=xlGuess, _
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
DataOption1:=xlSortNormal
Range("K3:N34").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("Archivio")
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)"
r = Cells(2, 18)
Range(Cells(1, 18), Cells(2, 20)).ClearContents
If r1 < r Then
If r1 = 2 Then
Range(Cells(r1 + 1, 1), Cells(r, 4)).Select
Selection.Insert shift:=xlDown
Cells(4, 5).Copy
Range(Cells(r1 + 1, 1), Cells(r, 4)).Select
ActiveSheet.Paste
Application.CutCopyMode = False
Else
Range(Cells(r1 + 1, 1), Cells(r, 4)).Select
Selection.Insert shift:=xlDown
End If
End If
If r1 < r Then d = r Else d = r1
Range("A3:F" & d).Select
Selection.Sort Key1:=Range("A3"), Order1:=xlAscending
For X = 3 To d Step 2
Range(Cells(X, 1), Cells(X, 14)).Interior.ColorIndex = 45
Next X
Range("A3:N" & r).Select 'seleziona l'area di stampa'
ind = Range("A3:N" & r).Address
ActiveSheet.PageSetup.PrintArea = ind
With ActiveSheet.PageSetup
.PrintTitleRows = "$1:$2"
.PrintTitleColumns = ""
End With
With ActiveSheet.PageSetup
.LeftHeader = "Stampato in Data &D - &T Pagine &P/&N" 'stampa data ora e numero di pagine'
.CenterHeader = "" & Chr(10) & "" & Chr(10) & "" & Chr(10) & "" & Chr(10) & "" & Chr(10) & _
"&""Arial,Grassetto Corsivo""&18Direzione N.C.P. Solliciano - Firenze&""Arial,Normale""&10" & Chr(10) & _
"&""Arial,Grassetto Corsivo""&12Variazioni Celle, Nuovi Arrivi, Uscite, in Data &D" '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 < r Then
Range(Cells(3, 2), Cells(r, 15)).Interior.ColorIndex = 0
Else
Range(Cells(3, 2), Cells(r1, 15)).Interior.ColorIndex = 0
End If
If r1 < r Then
Range(Cells(r1 + 1, 1), Cells(r, 4)).Select
Selection.Delete shift:=xlUp
End If
Cells(2, 1).Select
End Sub
ho provato così...sembra funzionare se mi ci date un'occhiata!
quello in grassetto è quello che ho inserito
ed ho eliminato
Option Explicit
Option Compare Text
Public RR As Integer, X As Integer
Sub Cancella_Dati_Condizionata()
Registrazione
