Discussione: Corso VBA
Visualizza messaggio singolo
Vecchio 08-09-2014, 00.24.16   #60
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
#7

Macro e Procedure varie



=> Annullare ogni azione - Undo in VBA
Codice:
Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range)
Application.EnableEvents = False
Application.Undo
Application.EnableEvents = True
End Sub
=> Avviare una macro premendo un tasto qualsiasi
Codice:
Private Sub Workbook_Activate()
For i = 1 To 250
On Error Resume Next
Application.OnKey Chr(i), "Macro1"
Next i
End Sub
=> Inserisci un collegamento ipertestuale
Codice:
Sub Add_Hyp()
    With ThisWorkbook.Sheets(2)
        .Activate
        .Hyperlinks.Add Range("A1"), "http://www.microsoft.com"
        .Shapes.AddShape msoShapeExplosion2, 45, 55, 90, 45
        .Hyperlinks.Add .Shapes(1), "http://www.microsoft.com"
    End With
End Sub
=> Incollare solo il valore
Codice:
Sub IncVal()
Selection.Copy
Selection.PasteSpecial Paste:=xlValues
Application.CutCopyMode = False
If ActiveCell.Text = "#N/D" Then ActiveCell = ""
End Sub
=> Ordina dati in decrescente
Nota: Ordinare i dati in base al valore presente nella cella D2
Codice:
Sub ordina()
Range("A2:F5").Select
Selection.Sort Key1:=Range("D2"), Order1:=xlDescending, Header:=xlGuess, _
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
DataOption1:=xlSortNormal
Range("A1").Select
End Sub
=> Eseguire una macro a un'ora prefissata
Nota: Una macro che viene eseguita ad unora precisa, usando la funzione Ontime.
Codice:
Private Sub Workbook_Open()
Application.OnTime TimeValue("22:00:00"), "Macro1"
End Sub
=> Avvia una macro con un clik sulla cella
Codice:
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
If Target.Address = "$A$1" Then MsgBox "forza !" 'Macro1
End Sub
=> Giorno della settimana e data
Codice:
Sub giornoedata()
Dim x As Date
x = Date
[B2] = Format(x, "dddd") & Space(2) & "-" & Space(2) & x 
End Sub
=> Eseguire un programma con "ritardo"
Codice:
Sub Test()
Sleep NumSeconds:=10
Shell ("percorso e nome programma")
End Sub

Sub Sleep(NumSeconds As Single)
Dim StartTime As Single
StartTime = Timer
While (Timer - StartTime) < NumSeconds
DoEvents
Wend
End Sub
=> Funzione somma in un range
Codice:
Sub Somma()
Set zona = Range([B3], [B3].End(xlDown))
[B3].End(xlDown).Select
ActiveCell.Offset(1, -1) = "Totale"
ActiveCell.Offset(1, 0) = WorksheetFunction.Sum(zona)
End Sub
=> Eseguire una macro quando la cella A3 selezionata
Codice:
Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Address = "$A$3" Then pippo
End Sub
=> Cambiare i punti con le virgole
Codice:
Sub CambiaPuntiVirgole()
For Each cell In Selection
If InStr(1, cell.Text, ".") > 0 Then
cell.Value = CDbl(Val(cell.Text))
End If
Next
End Sub
=> Togliere gli apostrofi
Nota : Toglie tutti gli apostrofi nelle celle
Codice:
Sub app1()
For Each cell In ActiveSheet.UsedRange
If cell.PrefixCharacter <> "" Then
cell.Formula = cell.Formula
End If
Next cell
End Sub
=> Sostituisce un carattere vietato con il carattere "_"
Nota : Questa funzione cambia i caratteri vietati per il nome del file, con il carattere "_".
Codice:
Function sost_car(fileName As String) As String
Dim illegal As Variant, counter As Integer
illegal = Array("<", ">", "?", "[", "]", ":", "|", "*", "/")
For counter = LBound(illegal) To UBound(illegal)
Do While InStr(fileName, illegal(counter))
Mid(fileName, InStr(fileName, illegal(counter)), 1) = "_"
Loop
Next counter
ReplaceIllegalChars = fileName
End Function
=> Salvare la cartella senza le macro
Codice:
Sub senzaM()
ThisWorkbook.Sheets.Copy
ActiveWorkbook.SaveAs MyNewPathAndFile
ThisWorkbook.Close False
End Sub
=> Conoscere il codice Ascii di un testo
Codice:
Function CodASCII$(txtin$)
Dim i As Integer
CodASCII = ""
For i = 1 To Len(txtin)
CodASCII = CodASCII & Asc(Mid(txtin, i, 1))
If i < Len(txtin) Then
CodASCII = CodASCII & "."
End If
Next i
End Function
=> Impedire_Taglia/Copia/Incolla
Autore : Tiziano Marmiroli
Codice:
Private Sub Workbook_Open()
With Application
.CellDragAndDrop = False
.ExtendList = False
End With
Application.CommandBars("Cell").Enabled = False
Application.OnKey "^x", ""
Application.OnKey "^c", ""
Application.OnKey "^v", ""

For Each Ctrl In Application.CommandBars.FindControls(ID:=19)
Ctrl.Enabled = False
Next Ctrl
For Each Ctrl In Application.CommandBars.FindControls(ID:=21)
Ctrl.Enabled = False
Next Ctrl
For Each Ctrl In Application.CommandBars.FindControls(ID:=22)
Ctrl.Enabled = False
Next Ctrl
End Sub

Private Sub Workbook_BeforeClose(Cancel As Boolean)
With Application
.CellDragAndDrop = True
.ExtendList = True
End With
Application.CommandBars("Cell").Enabled = True
Application.OnKey "^x"
Application.OnKey "^c"
Application.OnKey "^v"
Dim Ctrl As Office.CommandBarControl
For Each Ctrl In Application.CommandBars.FindControls(ID:=19)
Ctrl.Enabled = True
Next Ctrl
For Each Ctrl In Application.CommandBars.FindControls(ID:=21)
Ctrl.Enabled = True
Next Ctrl
For Each Ctrl In Application.CommandBars.FindControls(ID:=22)
Ctrl.Enabled = True
Next Ctrl
End Sub

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Application.CutCopyMode = False
End Sub
___________________________________

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