Procedura di creazione di una barra personalizzata

Esempi VBA

Alcuni esempi qui riportati sono stati presi dal sito www.vbaexpress.com

 

Piccole Macro Excel per iniziare con spiegazione passo passo

 

' METODI E PROPRIETA

' Membri: esistono due tipi

' Proprietà: membro che indica una caratteristica di un oggetto come , per esempio, NumberFormat

' Le proprietà sono seguite da =

' Metodi: membro che indica un'operazione da fare su un oggetto come per esempio Copy e ‘PasteSpecial

' I metodi possono non essere seguiti da niente (come per esempio Copy)

' oppure essere seguiti da argomenti che specificano la modalità in cui il metodo

' deve essere eseguito (per esempio PasteSpecial)

' Tali argomenti sono specificati preceduti da :=

 

' LA GUIDA

' il visulaizzatore oggetti comprende due tipi di schede

' a sinistra si hanno gli oggetti a destra i metodi e le proprietà relative agli oggetti selezionati

' con globali si intendono quegli oggetti "indipendenti", cioè che non devono essere riferiti

' a nessun oggetto. Infatti Activesheet, Range, ... non sono preceduti da nessun oggetto perchè

' hanno significato da soli. a destra si hanno le relative proprietà e moduli

' selezionando una di esse si vede in basso alla finestra una scritta tipo "Property ActiveCell As Range",

' ciò significa che la proprietà ActiveCell restituisce un oggetto che si comporta come l'oggetto Range

 

Sub ultimacella_selezionecorrente()

' seleziona l'ultima cella del foglio in cui è scritto qualcosa

' partendo dalla cella attiva

    ActiveCell.SpecialCells(xlLastCell).Select

   

' seleziona la prima cella dell'ultima riga in cui è scritto qualcosa

' solo per l'area corrente della cella selezionata

    Range("a2").Select

    ActiveCell.CurrentRegion.Select

    Selection.End(xlDown).Select

 

 

Sub spostarsi_sotto_cellaattiva()

' spostarsi sotto di una cella quando questa è la cella attiva

ActiveCell.Offset(1, 0).Range("a1").Select

'oppure

ActiveCell.Range("a2").Select

 

' spostarsi sotto di una cella sotto un'area selezionata

 

Sub Intervalli()

' definizione di un intervallo personale come caratteristiche e area

Dim MyRange As Range

Set MyRange = Range("c3:f8")

MyRange.Select

 

'oppure definizione di un intervallo assegnadogli un nome e un'area

 

Sub spostarsi_sotto_un_intervallo()

' se viene definito un intervallo oppure esso già c'è come risultante di un'operazione

' di copia o incolla, di sotto si spiega come mettersi sulla cella/riga successiva

'definizione del mio range

Dim MyRange As Range

Set MyRange = Range("b4:h19")

' selezione dell'ultima cella dell'intervallo

MyRange.Cells(MyRange.Cells.Count).Select

' creazione di un nuovo intervallo uguale spostato in sotto di una riga

Dim MyNewRange As Range

Set MyNewRange = MyRange.Offset(1, 0)

MyNewRange.Select

' selezionamento dell'ultima riga del nuovo intervallo che coincide con la prima

' riga successiva al vecchio intervallo

MyNewRange.Rows(MyNewRange.Rows.Count).Select

' ora volendo si può selezionare la prima cella di tale riga

' che sta sotto all'intervallo vecchio

Selection.Range("A1").Select

 

'le ultime due operazioni sono riassumibili in una

MyNewRange.Rows(MyNewRange.Rows.Count).Range("A1").Select

 

' in alternativa si può ottenere lo stesso risultato senza creare un nuovo intervallo

MyRange.Rows(MyRange.Rows.Count).Select

Selection.Offset(1, 0).Range("a1").Select

' anch'essa scrivibile senza l'istruzione select in mezzo

MyRange.Rows(MyRange.Rows.Count).Offset(1, 0).Range("a1").Select

 

Sub Scrivere_nelle_celle()

Selection.FormulaR1C1 = "----"

 

Sub Copia_Incolla()

Selection.Copy

Range("c20:G20").PasteSpecial

Application.CutCopyMode = False

 

Sub usare_il_with()

With Selection

    .Interior.ColorIndex = 8

    .WrapText = True

End With

 

Sub invertire_una_proprietà()

s = Selection.Font.Strikethrough

Selection.Font.Strikethrough = Not s

 

Sub uso_di_variabili()

' sostanzialmente ci sono due tipi di variabili: quelle che sono uguali al valore

' contenuto in una cella e quelle che sono uguali ad un determinato oggetto

' il primo tipo si scrive come sotto e assegna alla variabile il valore contenuto

' all'interno della cella

MyVar = Range("c5")

' il secondo tipo consente di chiamare una determinata proprietà col nome della variabile e

' la differenza sta nel fatto che si scrive set all'inizio

Set MyVar = Range("c3").Interior

' Aprendo la finestra variabili locali (Menu visualizza) è possibile (cliccando sui +) vedere le proprietà riferite

' alla variabile in corso

 

Sub usare_IF()

'l'istruzione IF permette di eseguire un'operazione solo se una determinata condizione è verificata come nell'esempio

If ActiveCell.Column < 256 Then

    ActiveCell.Offset(0, 1).Select

End If

' Abbiamo creato un If che dice di spostarsi a destra se la cella attiva

' occupa una colonna inferiore a 256

' nota che l'istruzione If può essere usata di solito solo se la risposta

' è del tipo SI o NO. Nota anche che finisce sempre con l'istruzione End If

 

' Ora gli diciamo cosa fare se la condizione invece non è verificata con ELSE

' nello specifico gli diciamo di selezionare la cella della riga sotto nella prima colonna

If ActiveCell.Column < 256 Then

    ActiveCell.Offset(0, 1).Select

Else

    Cells(ActiveCell.Row + 1, 1).Select

    End If

 

Sub IF_con_variabili()

' Usare If con il valore di una variabile

' se nel box non viene immesso niente

' la macro non va avanti

Dim myDate As String

myDate = Inputbox("Inserisci data")

If myDate <> "" Then

    If IsDate(myDate) Then

    Range("b3").FormulaR1C1 = myDate

    Else

    Range("b3").FormulaR1C1 = "ri-immetti data"

    End If

End If

 

Sub For_Each()

' Questa macro dà l'impostazione per eseguire un ciclo per ogni oggetto

' In particolare qui si chiede di proteggere ciascun foglio della libreria

Dim mysheet As Worksheet ' dimensiono la mia variabile come un foglio

Set mysheet = Worksheets(1) ' assegno per ora il valore di mySheet uguale al foglio 1

mysheet.Select

mysheet.Protect "puffo" 'ho protetto solo il foglio 1

 

' ora creo un ciclo per tutti i fogli

Dim mySheets As Worksheet

For Each mySheets In Worksheets

    mySheets.Select

    mySheets.Protect "puffo"

Next mySheets

'esercizio

Dim foglio As Worksheet

For Each foglio In Worksheets

    foglio.Unprotect "puffo"

Next foglio

 

Sub For_to()

' E' uguale all'istruzione For_Each, con

' la differenza che qui ci fermiamo quando lo vogliamo

' noi e non li facciamo tutti (Each)

Dim mysheet As Worksheet

Dim i As Integer 'creo una variabile contatore che è un numero naturale

For i = 1 To Worksheets.Count 'per i che va da 1 all'ultimo

    Set mysheet = Worksheets(i)

    mysheet.Protect "puffo"

Next i

 

Sub messaggi()

' messaggio con due opzioni si no

' creo una variabile uguale alla rispota che verrà data

MSGBOX "Questo è un messaggio con due opzioni", vbYesNo

Dim VarRisposta As VbMsgBoxResult

If VarRisposta = vbNo Then

    MSGBOX "Hai risposto NO", vbOKOnly

    Else

    MSGBOX "Hai risposto sì", , "TITOLO MIO"

End If

 

Sub UsoInputbox()

Application.Inputbox ("prova messaggio")

 

Sub Inputbox_con_variabile()

Dim MyVar As String

MyVar = Inputbox("prova messaggio con variabile")

 

Sub Do_Loop()

'La funzione do loop permette di eseguire un ciclo di istruzioni

'fin tanto che l'istruzione specificata da Do si verifica essere vera

    counter = 0 'definisce una variablie contatore che al momento è uguale a zero

    myNum = 20 ' definisce una variabile di valore pari a venti

    Do While myNum > 10 'è come se si dicesse al computer"inizia il ciclo e

    'e continualo fin tanto che la variabile myNum è maggiore di 10, quando

    ' non lo sarà più salta a Loop, cioè termina il ciclo

        myNum = myNum - 1

        counter = counter + 1

    Loop

 

Sub Dir_OpenFile()

'Questa sub contine due istruzioni:

' la prima è la funzione Dir che serve per immagazzinare il nome di un file

Dim MyPath As String

MyPath = "C:\"

'in questo modo ho definito una variabile che mi dice da dove pescare i miei file

'ora posso dirgli di recepire il nome del file andandolo a pescare dalla cartella che

' gli ho specificato con myPath e gli dico che sto cercando dei file con l'attributo vbNormal

Dim myFileName As String

myFileName = Dir(MyPath, vbNormal)

'ora gli posso dire di aprire il file

Workbooks.Open Filename:=MyPath & myFileName

'e ora di chiuderlo senza salvare

ActiveWorkbook.Close (False)

' il problema è che così apro solo il primo file che il computer

' trova nella cartella che io gli ho indicato

' posso creare un ciclo che gli dice di fare sempre questa operazione di individuazione apertura chiusura

' di tutti i file della cartella

MyPath = "C:\"

myFileName = Dir(MyPath, vbNormal)

Do While myFileName <> ""

    Workbooks.Open Filename:=MyPath & myFileName

    ActiveWorkbook.Close (False)

    myFileName = Dir 'riga che gli dice di andare avanti al successivo

    'Dir restituisce il primo nome di file che corrisponde a quello specificato in nomepercorso. Per ottenere i successivi

    'nomi di file corrispondenti a nomepercorso, chiamare di nuovo la funzione Dir senza alcun

    'argomento. Se non vengono trovati altri nomi di file corrispondenti, Dir restituirà

    'una stringa di lunghezza zero, dopodiché sarà necessario utilizzare di nuovo nomepercorso nelle successive chiamate,

    'altrimenti verrà generato un errore. È possibile passare a un nuovo nomepercorso senza trovare tutti i nomi di file che

    'corrispondono al nomepercorso corrente. Non è possibile tuttavia chiamare la funzione Dir in modo ricorsivo. Richiamando Dir con

    'l'attributo vbDirectory non verranno restituite sottodirectory in modo continuo.

    'Suggerimento   Dato che i nomi di file vengono individuati senza rispettare un ordine particolare, potrebbe essere utile salvarli

    'in una matrice e quindi ordinarla.

    Loop

 

Sub CancellaContenuto()

'questa macro cancella ciò che è scritto nella cella

Range("a1:b3").ClearContents

 

Sub ultimacella_selezionecorrente()

'

 

' seleziona l'ultima cella del foglio in cui è scritto qualcosa

' partendo dalla cella attiva

    Dim MyRange As Range

    Set MyRange = Range("i8").SpecialCells(xlLastCell)

   

' seleziona la prima cella dell'ultima riga in cui è scritto qualcosa

' solo per l'area corrente della cella selezionata

    Range("a2").Select

    ActiveCell.CurrentRegion.Select

    Selection.End(xlDown).Select

 

Sub var_ultimacella()

'

'

Dim myr As Range

Set myr = Range("a1").CurrentRegion

Dim LC As Range

Set LC = myr.Cells(myr.Cells.Count)

Range("d1:e1").AutoFill Destination:=myr.Range("d1", LC)

 

 

Sub Corri_altre_macro()

'

    Application.Run "Cartel1.xls!NomeMacro"

 

 

Sub selezione_intervallo_pieno()

'

 Sheets("Foglio2").Activate

Range("d4").Activate

    Dim Inter As Range

    Set Inter = Range(ActiveCell.End(xlToRight), ActiveCell.End(xlDown))

    Inter.Copy

    Sheets("Foglio1").Activate

    Range("G10").PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _

        :=False, Transpose:=False

    Application.CutCopyMode = False

 

Sub Cancella_righe()

'

    Rows("20:33").Delete Shift:=xlUp

 

 

Sub sommadicolonna_e_address()

Dim Ranget As Range

Set Ranget = Range("b4:h19")

Dim MyTot As Range

Set MyTot = Ranget.Offset(Ranget.Rows.Count).Rows(1)

MyTot.Cells(1) = Ranget.Columns(1).Address

'MyTot.Cells(1) = Ranget.Columns(1).Address(False, False)

MyTot.Formula = "=SUM(" & Ranget.Columns(1).Address(False, False) & ")"

With MyTot.Font

    .FontStyle = "Grassetto Corsivo"

    End With

 

Sub grassetto_corsivo()

'

    With Selection.Font

        .Name = "Arial"

        .FontStyle = "Grassetto Corsivo"

        .Size = 10

        .Strikethrough = False

        .Superscript = False

        .Subscript = False

        .OutlineFont = False

        .Shadow = False

        .Underline = xlUnderlineStyleNone

        .ColorIndex = xlAutomatic

    End With

 

Sub Attendi()

Dim PauseTime, Start, Finish, TotalTime

If (MSGBOX("Scegliere Sì per interrompere l'applicazione per 5 secondi", 4)) = vbYes Then

    PauseTime = 5    ' Imposta la durata.

    Start = Timer    ' Imposta l'ora di inizio.

    Do While Timer < Start + PauseTime

        DoEvents        ' Passa il controllo ad altri processi.

    Loop

    Finish = Timer    ' Imposta l'ora di fine della pausa.

    TotalTime = Finish - Start    ' Calcola il tempo totale.

    MSGBOX "Interruzione di " & TotalTime & " secondi"

Else

    End

End If

 

Sub GestioneErrore()

'per gestire un errore gli si può dire

'di saltare, nel caso si verifichi l'errore

'alla riga successiva oppure mandarlo

'ad un'etichetta o una riga

'gli genero un errore dicendo di selezionare il folgio1000!

 

'primo metodo

On Error Resume Next

Worksheets(1000).Activate

MSGBOX "Errore saltato"

 

'secondo metodo

Worksheets(1000).Activate

On Error GoTo oltreErrore

Worksheets(15).Activate

 

oltreErrore:

MSGBOX "Errore saltato anche in questo caso"

 

Proteggi simultaneamente tutti i fogli

 

Sub Proteggi_tutti_fogli()

Dim Sheet As Worksheet

Application.ScreenUpdating = False

For Each Sheet In Worksheets

Sheet.Protect ("xxx")

Next Sheet

End Sub

 

Sub Sproteggi_tutti_fogli()

Application.ScreenUpdating = False

Dim Sheet As Worksheet

For Each Sheet In Worksheets

Sheet.Unprotect ("xxx")

Next Sheet

 

Funzione per saltare le celle vuote nella definizione di un intervallo

 

Function CoolRange(MyRange As Range, Optional NoNumbers As Boolean, Optional NoTexts As Boolean) As Range

 

    Dim RgConstants As Range, RgFormulas As Range

    Dim MyOption As Integer 'string to consider optional values

       

    If NoNumbers = False Then MyOption = 1

    If NoTexts = False Then MyOption = MyOption + 2

       

        MyOption = MyOption + 20

 

    On Error Resume Next

    Set RgConstants = MyRange.SpecialCells(xlCellTypeConstants, MyOption)

    Set RgFormulas = MyRange.SpecialCells(xlCellTypeFormulas, MyOption)

   

    On Error GoTo 0

    Select Case True

        Case RgConstants Is Nothing And RgFormulas Is Nothing: Exit Function

        Case RgConstants Is Nothing: Set CoolRange = RgFormulas

        Case RgFormulas Is Nothing: Set CoolRange = RgConstants

        Case Else: Set CoolRange = Union(RgConstants, RgFormulas)

    End Select

 

    Set RgConstants = Nothing

    Set RgFormulas = Nothing

 

BrowseForFolder per cercare una cartella con VBA in Excel

 

Function GetFolderPath() As String

    Dim oShell As Object

    Set oShell = CreateObject("Shell.Application"). _

    BrowseForFolder(0, "Please select folder", 0, "c:\\")

    If Not oShell Is Nothing Then

        GetFolderPath = oShell.Items.Item.Path

    Else

        GetFolderPath = vbNullString

    End If

    Set oShell = Nothing

 

Macro per cambiare con VBA l’icona di Excel

 

Option Explicit

 

Declare Function GetActiveWindow32 Lib "USER32" Alias _

                                   "GetActiveWindow" () As Integer

 

Declare Function SendMessage32 Lib "USER32" Alias _

                               "SendMessageA" (ByVal hWnd As Long, ByVal wMsg As Long, _

                                               ByVal wParam As Long, ByVal lParam As Long) As Long

 

Declare Function ExtractIcon32 Lib "SHELL32.DLL" Alias _

                               "ExtractIconA" (ByVal hInst As Long, _

                                               ByVal lpszExeFileName As String, _

                                               ByVal nIconIndex As Long) As Long

                                              

'modification of code from Excel Experts E-Letter Archives.

'Original code By Jim Rech can be found by following this

 

Sub ChangeApplicationIcon()

 

      Dim Icon&

     

      '*****Change Icon To Suit*******

      Const NewIcon$ = "notepad.exe"

      '*****************************

     

      Icon = ExtractIcon32(0, NewIcon, 0)

      SendMessage32 GetActiveWindow32(), &H80, 1, Icon      '< 1 = big Icon

      SendMessage32 GetActiveWindow32(), &H80, 0, Icon      '< 0 = small Icon

 

 

Connessione da Excel ad un database access con vba

 

Option Explicit

 

‘Aggiungere i riferimenti alle librerie DAO e Office

 

Public gdbCurrentDB As Database

Public objRecordset As Recordset

Public objTableDefs As TableDef

Public tname As String 'nome della tabella

Public counter As Long

 

Sub DbConnect()

'connessione veloce ad un database

On Error GoTo herr

 Set gdbCurrentDB = OpenDatabase("C:\....miodatabase.mdb", True)

 Exit Sub

herr:

 Set gdbCurrentDB = Nothing

End Sub

 

 

Sub GetData()

'Connessione veloce ad una tabella o query

'tname è il nome della tabella

 

Dim k, j, l As Long

Dim n As Variant

On Error GoTo err01

Set objRecordset = gdbCurrentDB.OpenRecordset(tname)

Exit Sub

err01:

MsgBox "impossibile recuperare i dati richiesti."

End Sub

 

Public Sub GetTableList(rctl As Control)

  'recupera tutte le tabelle

'rctl è un controllo tipo listbox

 

On Error GoTo FTLErr

  Dim i As Integer

  Dim sTmp As String

  For i = 0 To gdbCurrentDB.TableDefs.Count - 1

    sTmp = gdbCurrentDB.TableDefs(i).Name

        If (gdbCurrentDB.TableDefs(StripConnect(sTmp)).Attributes And dbSystemObject) = 0 Then

    sTmp = gdbCurrentDB.TableDefs(i).Name

    rctl.AddItem sTmp

        End If

  Next

 

'se vuoi recuperare anche le queries

'  For i = 0 To gdbCurrentDB.QueryDefs.Count - 1

'    sTmp = gdbCurrentDB.QueryDefs(i).Name

'    rctl.AddItem sTmp

'    Next

  Exit Sub

FTLErr:

  Exit Sub

End Sub

 

Private Function StripConnect(rsTblName As String) As String

  If InStr(rsTblName, "->") > 0 Then

    StripConnect = Left(rsTblName, InStr(rsTblName, "->") - 2)

  Else

    StripConnect = rsTblName

  End If

 

Criteri multipli per CONTA.SE e SOMMA.SE

 

Conteggio dei valori nell’intervallo c4:c11 solo se maggiori di zero e minori del valore indicato nella cella F13

 

Controlla l’assistente di Office con VBA Excel

 

Sub OfficeAssistant()

    With Assistant

        .Visible = True

        With .NewBalloon

            .Heading = "Come ti aiuto?"

            .Labels(1).Text = "Sono stanco"

            .Labels(2).Text = "Ho troppi compiti"

            .Labels(3).Text = "Voglio giocare"

            .BalloonType = msoBalloonTypeButtons

            .Button = msoButtonSetNone

            .Mode = msoModeModeless

            .Callback = "Response"

            .Show

        End With

    End With

 

 

Sub Response(bln As Balloon, lbtn As Long, lPriv As Long)

    bln.Close

    Select Case lbtn

        Case Is = 1

            MsgBox "Riposati", vbInformation

        Case Is = 2

            MsgBox "Che aspetti. Inizia", vbCritical

        Case Is = 3

            MsgBox "Chiama tre amici e tira fuori il risiko", vbInformation

    End Select

 

Copia una cartella e tutto il suo contenuto

 

Sub FSO_Copy_Folders_New_Location()

 

‘se necessario aggiungere il riferimento alla libreria Microsoft Scripting Runtime

   Dim fsoObj As Scripting.FileSystemObject

   Const stSourceFolder As String = "c:\Test\excel"

  

   Const stTargetFolder As String = "\\Destination"

  Set fsoObj = New Scripting.FileSystemObject

 

   With fsoObj

            If .FolderExists(stTargetFolder) Then

         .DeleteFolder (stTargetFolder)

      End If

            .CopyFolder Source:=stSourceFolder, Destination:=stTargetFolder, OverWriteFiles:=True

   End With

 

   MsgBox "La cartella" & stSourceFolder & _

                " è stata copiata in" & stTargetFolder & ".", vbInformation

   Set fsoObj = Nothing

 

Sposta Cartella e tutto il suo contenuto

 

Sub FSO_Move_Folders_New_Location()

   Dim fsoObj As Scripting.FileSystemObject

   Const stSourceFolder As String = "c:\Test\excel"

   Const stTargetFolder As String = "C:\Destination2"

 

   Set fsoObj = New Scripting.FileSystemObject

 

   With fsoObj

      If .FolderExists(stTargetFolder) Then

         .DeleteFolder (stTargetFolder)

      End If

 

      .CopyFolder Source:=stSourceFolder, Destination:=stTargetFolder, OverWriteFiles:=True

     .DeleteFolder (stSourceFolder)

   End With

 

   MsgBox "La cartella" & stSourceFolder & _

                " spostata in" & stTargetFolder & ".", vbInformation

   Set fsoObj = Nothing

 

Creare via codice un riferimento ad una libreria

 

Sub Add_External_Reference_()

   Dim rVBReference As VBIDE.Reference

   Dim wbBook As Workbook

   'GUID Microsoft Scripting Runtime.

 

   Const stGuid As String = "{420B2830-E718-11CF-893D-00A0C9054228}"

 

   Const stName As String = "MS Scripting Runtime"

 

   Set wbBook = ThisWorkbook

   On Error GoTo Error_Handling

   With wbBook

      For Each rVBReference In .VBProject.References

 

         If rVBReference.GUID = stGuid Then

            MsgBox "La libreria di " & stName & " è già attiva!", vbInformation

            GoTo ExitHere

         End If

 

      Next rVBReference

            .VBProject.References.AddFromGuid stGuid, 1, 0

      MsgBox "La reference " & stName & " è stata creata!", vbInformation

      GoTo ExitHere

   End With

 

ExitHere:

   Set rVBReference = Nothing

 

   Exit Sub

Error_Handling:

 

   MsgBox "Impossibile creare la reference  " & stName & vbCrLf & " poiché non esiste su questo PC.", vbCritical

 

   Resume ExitHere

 

Eliminare un riferimento ad una libreria via codice

 

Sub Delete_Reference()

   Dim wbBook As Workbook

 

   Const stDescription As String = "Scripting"

 

   Set wbBook = ThisWorkbook

   On Error GoTo Error_Handling

   With wbBook.VBProject.References

      .Remove .Item(stDescription)

   End With

 

    MsgBox "Reference rimossa!", vbInformation

 

ExitHere:

 

   Exit Sub

Error_Handling:

   MsgBox "Reference non esistente!", vbInformation

   Resume ExitHere

 

 

Macro per eliminare una cartella non vuota

Sub RemoveDir_WithFiles()

Creare reference a Microsoft scripting runtime library

 

Dim objFSO As Object

 

On Error GoTo DelErr

'// Attenzione: Verrà cancellata la cartella Mydir senza avvisi

Set objFSO = CreateObject("Scripting.FileSystemObject")

objFSO.DeleteFolder "C:\Mydir", True

 

XitProperly:

Set objFSO = Nothing

 

Exit Sub

DelErr:

MsgBox "Errore:=" & Err.Number & vbCr & Err.Description

Resume XitProperly

 

Trova l’ultima riga o cella non vuota

 

Function xlLastRow(Optional WorksheetName As String) As Long

    If WorksheetName = vbNullString Then WorksheetName = ActiveSheet.Name

    With Worksheets(WorksheetName)

        On Error Resume Next

        xlLastRow = .Cells.Find("*", .Cells(1), xlFormulas, _

        xlWhole, xlByRows, xlPrevious).Row

        If Err <> 0 Then xlLastRow = 0

    End With   

 

Mostra tutte le icone (faceId) dei bottoni delle barre di Excel

 

Sub listAllFaces()

‘codice originale wrox

Dim i As Integer

Dim j As Integer

Dim k As Integer

Dim cbCtl As CommandBarControl

Dim cbBar As CommandBar

 

On Error GoTo Recover

Application.ScreenUpdating = False

 

Set cbBar = CommandBars.Add(Position:=msoBarFloating, MenuBar:=False, temporary:=True)

Set cbCtl = cbBar.Controls.Add(Type:=msoControlButton, temporary:=True)

 

k = 1

Do

    For j = 1 To 15

    i = i + 1

    Application.StatusBar = "Face ID=" & i

    cbCtl.FaceId = i

    cbCtl.CopyFace

    ActiveSheet.Paste Cells(k, j + 1)

    Cells(k, j).Value = i

    Next j

    k = k + 1

Loop

 

Recover:

If Err.Number = 1004 Then Resume Next

Application.StatusBar = False

cbBar.Delete

 

Recupera che tipo di oggetto è selezionato

 

Sub System_TypeOfSelection()

MsgBox "E’ selezionato un: " & TypeName(Selection) & ".", vbInformation

 

Funzione per verificare se una cartella esiste

 

Function ChkFileExists(strFileName As String) As Boolean

If Dir(strFileName) <> "" Then

ChkFileExists = True

Else

ChkFileExists = False

End If

 

Tutte le informazioni di sistema tramite VBA

 

Sub OperatingSystem()

Debug.Print "------------------------------------------------------------"

Debug.Print Application.OperatingSystem

Debug.Print Application.Name

Debug.Print Application.LibraryPath

Debug.Print Application.MemoryTotal

Debug.Print Application.MemoryUsed

Debug.Print Application.MemoryFree

Debug.Print Application.StartupPath

Debug.Print Application.UILanguage

Debug.Print Application.UsableHeight

Debug.Print Application.UsableWidth

Debug.Print Application.WindowsForPens

Debug.Print Application.Version

Debug.Print Application.Build

Debug.Print Application.OrganizationName

Debug.Print Application.UserName

Debug.Print "xlCountrycode : " & Application.International(xlCountryCode)

Debug.Print "xlCountrySetting : " & Application.International(xlCountrySetting)

Debug.Print "xlNonEnglishFunctions : " & Application.International(xlNonEnglishFunctions)

Debug.Print "xlMetric : " & Application.International(xlMetric)

Debug.Print "xlCountrySetting : " & Application.International(xlCountrySetting)

Debug.Print "------------------------------------------------------------"

 

Scrivere e utilizzare il registro di Windows con vba

 

Sub SalvaSettings()

 

'In questo esempio l'istruzione SaveSetting viene innanzitutto utilizzata per creare

'voci nel registro di Windows o nel file ini in piattaforme Windows a 16 bit per

'l 'applicazione MyApp. L'istruzione DeleteSetting viene quindi utilizzata per eliminarle

 

' Inserisce alcune impostazioni nel registro.

SaveSetting appname:="MyApp", Section:="Startup", _

            Key:="Top", setting:=75

SaveSetting "MyApp", "Startup", "Left", 50

' Rimuove la sezione e tutte le impostazioni dal

' registro.

DeleteSetting "MyApp", "Startup"

 

Sub GetTuttiSettingdiUnAppl()

'In questo esempio l'istruzione SaveSetting viene innanzitutto utilizzata

'per creare voci nel registro di Windows per l'applicazione specificata

'dall'argomento appname. La funzione GetAllSettings viene quindi utilizzata

'per visualizzare le impostazioni. Si noti che non è possibile utilizzare la

'funzione GetAllSettings per recuperare i nomi di applicazione e i nomi di sezione.

'L'istruzione DeleteSetting viene infine utilizzata per eliminare le voci relative

'all'applicazione.

 

' Variabile Variant per archiviare la matrice bidimensionale

' restituita da GetAllSettings.

' Valore Integer per memorizzare il contatore.

Dim MySettings As Variant, intSettings As Integer

' Inserisce alcune impostazioni nel registro.

SaveSetting appname:="MyApp", Section:="Startup", _

Key:="Top", setting:=75

SaveSetting "MyApp", "Startup", "Left", 50

' Legge le impostazioni.

MySettings = GetAllSettings(appname:="MyApp", Section:="Startup")

    For intSettings = LBound(MySettings, 1) To UBound(MySettings, 1)

        Debug.Print MySettings(intSettings, 0), MySettings(intSettings, 1)

    Next intSettings

DeleteSetting "MyApp", "Startup"

 

Autodistruggi un file aperto

 

Sub KillMe()

    With ThisWorkbook

        .Saved = True

        .ChangeFileAccess Mode:=xlReadOnly

        Kill .FullName

        .Close False

    End With

End Sub