questa macro è assegnata a un tasto che stampa di nomi ma non li mette in ordine alfabetico prima della stampa...
il codice che dovrebbe mettere in ordine alfabetico inizia dalla riga 26..
chi me lo sinstema?
grazie!
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 CL, CL2, RNG, RNG2, NOME, COGNOME
'
Application.ScreenUpdating = False
'
Sheets("FEMMINILE").Select
Set RNG = Range("B5:B200")
For Each CL In RNG
If CL <> "" Then
COGNOME = CL
NOME = CL.Offset(0, 1).Value
Sheets("ARCHIVIO").Select
Set RNG2 = Range("G3:G300")
For Each CL2 In RNG2
If CL2 = COGNOME And CL2.Offset(0, 1).Value = NOME Then
CL2.ClearContents
CL2.Offset(0, 1).ClearContents
CL2.Offset(0, 2).ClearContents
CL2.Offset(0, 3).ClearContents
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("A2").Select
Application.EnableEvents = True
Application.ScreenUpdating = True
End If
Next
End If
Next
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
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
Registrazione
