Discussione: Corso VBA
Visualizza messaggio singolo
Vecchio 08-09-2014, 00.21.49   #57
Alexsandra
Senior Member
WT Expert
 
L'avatar di Alexsandra
 
Registrato: 19-05-2007
Loc.: Verona
Messaggi: 1.208
Alexsandra è un gioiello raroAlexsandra è un gioiello raroAlexsandra è un gioiello raroAlexsandra è un gioiello raro
#4

Macro e Procedure varie riferite al foglio di lavoro


=> Mostra tutti i fogli della cartella aperta
Codice:
Sub ScorreFogli()
For i = 1 To Worksheets.Count
With Worksheets(i)
.Activate
MsgBox .Name
End With
Next
End Sub
=> Selezionare tutti i fogli di una cartella
Codice:
Sub SelezionaFogli()
Dim myarray()
ReDim myarray(1 To ActiveSheet.Index)
For i = 1 To ActiveSheet.Index
myarray(i) = i
Next i
Worksheets(myarray).Select
End sub
=> Proteggi e sproteggi tutti i fogli
Codice:
Sub Proteggere()
Dim fgl As Integer
fgl = ActiveWorkbook.Sheets.count
Application.ScreenUpdating = False
For i = 1 To fgl
Worksheets(i).Protect Password:="blabla"
Next i
End Sub

Sub sproteggere()
Dim fgl As Integer
fgl = ActiveWorkbook.Sheets.count
Application.ScreenUpdating = False
For i = 1 To fgl
Worksheets(i).Unprotect Password:="blabla"
Next i
End Sub
=> Crea intervallo in un foglio
Codice:
Private Sub Worksheet_Deactivate()
Dim mioadd As String
mioadd = Sheets("Foglio2").Range(Sheets("Foglio2").Cells(2, 1), Sheets("Foglio2").Cells(65536, 1).End(xlUp)).Address
ActiveWorkbook.Names.Add Name:="Codice", RefersTo:="=Foglio2!" & mioadd
mioadd = Sheets("Foglio2").Range(Sheets("Foglio2").Cells(2, 1), Sheets("Foglio2").Cells(65536, 3).End(xlUp)).Address
ActiveWorkbook.Names.Add Name:="Dati", RefersTo:="=Foglio2!" & mioadd
Sheets("Foglio2").Range("A1").Sort Key1:=Sheets("Foglio2").Range("A1"), Order1:=xlAscending, Header:=xlGuess, OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom
End Sub
=> Verificare che un Foglio esista
Nota: Riporta il valore True se il foglio esiste oppure False per il contrario
Codice:
Sub test()
MsgBox foglioE("fogliol1")
End Sub

Function foglioE(Nom$) As Boolean
On Error Resume Next
foglioE = Sheets(Nom).Name <> ""
Err.Clear
End Function
=> Proteggere un foglio usando UserInterfaceOnly
Codice:
Sub ProtectionOn()
On Error Resume Next
For Each sht In ActiveWorkbook.Worksheets
With sht
.Select
.Protect Password:="pippo", UserInterfaceOnly:=True
End With
Next
End Sub
=> inserire un commento con un formato diverso dello standard
Codice:
Sub Inscommento()
With ActiveCell.AddComment.Shape.OLEFormat.Object
 .Text = ""
 .Font.Name = "Calibri"
 .Font.Size = 12
End With
ActiveCell.Comment.Visible = True
ActiveCell.Comment.Shape.Select True
End Sub
=> Cambiare formato a un commento
Codice:
Sub Ins_Comm()
Dim riga1, riga2, riga3, riga4, riga5, testo
Range("A1").ClearComments
[color=green]'creazione testo del commento
riga1 = vbLf & Application.UserName & ", " & Format(Date, "dd/mm/yyyy") & " :" & vbLf
riga2 = "Configurazione del computer :" & vbLf
riga3 = "- " & Application.OperatingSystem & vbLf
riga4 = "- Versione Excel : " & Application.Version & vbLf
riga5 = " Solo un esempio" & vbLf
testo = riga1 + riga2 + riga3 + riga4 + riga5
With Cells(1, 1).AddComment(testo).Shape.OLEFormat.Object.Font
'Tipo e dimensione carattere
.Name = "Arial" 
.Size = 10
End With
With Cells(1, 1).Comment.Shape
.AutoShapeType = msoShapeExplosion1
.TextFrame.AutoSize = True
'colore sfondo del commento
.OLEFormat.Object.Interior.ColorIndex = 24
 'colore del bordo
.Line.ForeColor.SchemeColor = 10
'stile del bordo (doppio per questo esempio)
.Line.Weight = 3# 
'spessore del bordo
.Line.Style = msoLineThinThin 
'1° riga in grassetto
.TextFrame.Characters(1, Len(riga1)).Font.Bold = True 
testo = riga1 + riga2 + riga3 + riga4
With .TextFrame.Characters(Len(testo) + 1, Len(riga5)).Font
'ultima riga in grassetto e di dimensioni diverse
.Bold = True 
.Size = 16
End With
End With
End Sub
=> Inserire un’immagine in un commento
Nota: Viene mostrata la finestra di scelta dei file per Inserire un’immagine come sfondo nel commento
Codice:
Sub Imgcommento()
Range("A1").Comment.Delete
Range("A1").AddComment
ChDrive "C"
ChDir "C:\Test\"
ImgFile = Application.GetOpenFilename
If ImgFile = False Then Exit Sub
With Range("A1").Comment
.Shape.Fill.UserPicture ImgFile
End With
End Sub
=> Copiare il formato di un foglio in un altro foglio
Nota : Permette di copiare il formato di un foglio in un altro foglio. Copia soltanto il formato.
Codice:
Sub test()
copiaFF "Foglio1", "Foglio2"
End Sub

Sub copiaFF(origine As String, target As String)
Sheets(origine).Cells.Copy
Sheets(target).Cells.PasteSpecial Paste:=xlFormats
Application.CutCopyMode = False
End Sub
=> Reperire il nome del foglio precedente e seguente al foglio attivo
Codice:
Sub foglioS()
ActiveSheet.Next.Select
End Sub

Sub foglioP()
ActiveSheet.Previous.Select
End Sub
=> Verifica se un dato inserito esiste già
Nota: L'esempio seguente verifica, mentre si sta inserendo un nome oppure un numero, se quest'ultimo sia gia' stato inserito: Autore: Microsoft
Codice:
Sub auto_open()
Worksheets("Foglio1").OnEntry ="Verifica"
End Sub

Sub Verifica()
valor = ActiveCell.Value
Selection.End(xlUp).Select
varinizio = ActiveCell.Row
Selection.End(xlDown).Select
varfine = ActiveCell.Row - 1
For y = varinizio To varfine
If Cells(y, 1).Value = valor Then
MsgBox "Nominativo gia’ esistente"
End If
Next y
End Sub
___________________________________

- Il primo fondamento della sicurezza non e' la tecnologia, ma l'attitudine mentale -
Alexsandra non è collegato