Ho compilato una macro in VBA che mi smista un certo numero di schede ( 16 in questo caso )
e le mette in un'area a seconda della loro competenza, di stampa o di archiviazione od entrambe.
VEDI FILE ESEMPIO https://www.dropbox.com/s/qd6bojx8u8dtk ... 2.zip?dl=0
Nel file di esempio oltre alla macro in VBA ho anche una macro nel vecchio linguaggio 4.0 .
Entrambe le macro funzionano alla perfezione, ma quella che ho scritto in VBA la trovo troppo complessa e obsoleta e vorrei migliorarla.
questo è il mio compilato:
- Codice: Seleziona tutto
Sub SmistaSchede()
Windows("SmistaSchede2.xlsm").Activate
Sheets("P0").Select
For h = 1 To 16 ' SCRIVE V NELLE SCHEDE DA STAMPARE E ARCHIVIARE
Dim rng As Range
Dim c As Range
Dim s As String
Dim sh As Worksheet
Set sh = ThisWorkbook.Worksheets("P0")
s = [L6] ' SCRIVE V NELLE SCHEDE DA STAMPARE E ARCHIVIARE
Range("R9,R29,R49,R69,R89,R109,R129,R149,R169,R189,R209,R229,R249,R269,R289,R309").Select
With sh
Set rng = .Range("R9,R29,R49,R69,R89,R109,R129,R149,R169,R189,R209,R229,R249,R269,R289,R309")
For Each c In rng
If UCase(c.Value) = UCase(s) Then
c.Select
ActiveCell = "V"
Exit For
End If
Next
End With
Next
Set sh = Nothing
Set c = Nothing
Set rng = Nothing
For i = 1 To 16 ' CANCELLA SCHEDE CON TOT ORE ZERO
Dim rng1 As Range
Dim c1 As Range
Dim s1 As String
Dim sh1 As Worksheet
Set sh1 = ThisWorkbook.Worksheets("P0")
s1 = [L6] ' ORE ZERO ELIMINO LE SCHEDE VUOTE
Range("R10,R30,R50,R70,R90,R110,R130,R150,R170,R190,R210,R230,R250,R270,R290,R310").Select
With sh1
Set rng1 = .Range("R10,R30,R50,R70,R90,R110,R130,R150,R170,R190,R210,R230,R250,R270,R290,R310")
For Each c1 In rng1
If UCase(c1.Value) = UCase(s1) Then
c1.Select
ActiveCell.Offset(-1, -7).Select
ActiveCell.Resize(20, 8).Select
Selection.Delete Shift:=xlUp
Exit For
End If
Next
End With
Next
Set sh1 = Nothing
Set c1 = Nothing
Set rng1 = Nothing
For j = 1 To 16 ' CANCELLA SCHEDE SENZA NOME DIPENDENTE
Dim rng2 As Range
Dim c2 As Range
Dim s2 As String
Dim sh2 As Worksheet
Set sh2 = ThisWorkbook.Worksheets("P0")
s2 = [L6] ' DIPENDENTE VUOTO ELIMINO LE SCHEDE
Range("N9,N29,N49,N69,N89,N109,N129,N149,N169,N189,N209,N229,N249,N269,N289,N309").Select
With sh2
Set rng2 = .Range("N9,N29,N49,N69,N89,N109,N129,N149,N169,N189,N209,N229,N249,N269,N289,N309")
For Each c2 In rng2
If UCase(c2.Value) = UCase(s2) Then
c2.Select
ActiveCell.Offset(0, -3).Select
ActiveCell.Resize(20, 8).Select
Selection.Delete Shift:=xlUp
Exit For
End If
Next
End With
Next
Set sh2 = Nothing
Set c2 = Nothing
Set rng2 = Nothing
For k = 1 To 16 ' ELIMINA SCHEDE DIPENDENTE ASSENTE A
Dim rng3 As Range
Dim c3 As Range
Dim s3 As String
Dim sh3 As Worksheet
Set sh3 = ThisWorkbook.Worksheets("P0")
s3 = [L3] ' A ELIMINA SCHEDE DIPENDENTE ASSENTE
Range("R9,R29,R49,R69,R89,R109,R129,R149,R169,R189,R209,R229,R249,R269,R289,R309").Select
With sh3
Set rng3 = .Range("R9,R29,R49,R69,R89,R109,R129,R149,R169,R189,R209,R229,R249,R269,R289,R309")
For Each c3 In rng3
If UCase(c3.Value) = UCase(s3) Then
c3.Select
ActiveCell.Offset(0, -7).Select
ActiveCell.Resize(20, 8).Select
Selection.Delete Shift:=xlUp ' ELIMINA CELLE IN ALTO
Exit For
End If
Next
End With
Next
Set sh3 = Nothing
Set c3 = Nothing
Set rng3 = Nothing
For l = 1 To 16 ' COPIA SCHEDE SOLO DA STAMPARE S e le elimina dalla lista da archiviare
Dim rng4 As Range
Dim c4 As Range
Dim s4 As String
Dim sh4 As Worksheet
Set sh4 = ThisWorkbook.Worksheets("P0")
s4 = [L4] ' S STAMPA E NON ARCHIVIA COPIA SCHEDE DA STAMPARE
Range("R9,R29,R49,R69,R89,R109,R129,R149,R169,R189,R209,R229,R249,R269,R289,R309").Select
With sh4
Set rng4 = .Range("R9,R29,R49,R69,R89,R109,R129,R149,R169,R189,R209,R229,R249,R269,R289,R309")
For Each c4 In rng4
If UCase(c4.Value) = UCase(s4) Then
c4.Select
ActiveCell.Select ' SELEZIONA LA CELLA ATTIVA
ActiveCell = "X" ' SCRIVE X NELLA CELLA ATTIVA
ActiveCell.Offset(0, -7).Select
ActiveCell.Resize(20, 8).Select
Selection.Copy
Range("AC9").Select ' SELEZIONA CELLA
Selection.Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
Exit For
End If
Next
End With
Next
Set sh4 = Nothing
Set c4 = Nothing
Set rng4 = Nothing
For m = 1 To 16 ' ELIMINA SCHEDE SOLO DA STAMPARE X
Dim rng5 As Range
Dim c5 As Range
Dim s5 As String
Dim sh5 As Worksheet
Set sh5 = ThisWorkbook.Worksheets("P0")
s5 = [L1] ' A ELIMINA SCHEDE SOLO DA STAMPARE X
Range("R9,R29,R49,R69,R89,R109,R129,R149,R169,R189,R209,R229,R249,R269,R289,R309").Select
With sh5
Set rng5 = .Range("R9,R29,R49,R69,R89,R109,R129,R149,R169,R189,R209,R229,R249,R269,R289,R309")
For Each c5 In rng5
If UCase(c5.Value) = UCase(s5) Then
c5.Select
ActiveCell.Offset(0, -7).Select
ActiveCell.Resize(20, 8).Select
Selection.Delete Shift:=xlUp ' ELIMINA CELLE IN ALTO
Exit For
End If
Next
End With
Next
Set sh5 = Nothing
Set c5 = Nothing
Set rng5 = Nothing
For n = 1 To 16 ' COPIA SCHEDE DA STAMPARE E ARCHIVIARE
Dim rng6 As Range
Dim c6 As Range
Dim s6 As String
Dim sh6 As Worksheet
Set sh6 = ThisWorkbook.Worksheets("P0")
s6 = [L2] ' COPIA SCHEDE DA STAMPARE E ARCHIVIARE
Range("R9,R29,R49,R69,R89,R109,R129,R149,R169,R189,R209,R229,R249,R269,R289,R309").Select
With sh6
Set rng6 = .Range("R9,R29,R49,R69,R89,R109,R129,R149,R169,R189,R209,R229,R249,R269,R289,R309")
For Each c6 In rng6
If UCase(c6.Value) = UCase(s6) Then
c6.Select
ActiveCell.Select ' SELEZIONA LA CELLA ATTIVA
ActiveCell = "X" ' SCRIVE X NELLA CELLA ATTIVA
ActiveCell.Offset(0, -7).Select
ActiveCell.Resize(20, 8).Select
Selection.Copy
Range("AC9").Select ' SELEZIONA CELLA
Selection.Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
Exit For
End If
Next
End With
Next
Set sh6 = Nothing
Set c6 = Nothing
Set rng6 = Nothing
Application.CutCopyMode = False ' COPIA ANNULLA
End Sub
siccome sto traducendo tutte le macro di un mio programma dal 4.0 al VBA ho molta difficoltà a capire come funziona la logica del VBA.
Spero che qualcuno possa aiutarmi
Grazie
Roberto
EDIT Flash: inserito il codice macro nel Tag Code
E' opportuno che ogni utente utilizzi il Tag Code per formule ma, soprattutto, per il codice macro