Macro per Fogli

=> Annullare ogni azione - Undo in VBA
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
Private Sub Workbook_Activate()
For i = 1 To 250
On Error Resume Next
Application.OnKey Chr(i), “Macro1″
Next i
End sub

=> Crea intervallo in un foglio
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

=> Incollare solo il valore
Sub IncVal()
Selection.Copy
Selection.PasteSpecial Paste:=xlValues
Application.CutCopyMode = False
If ActiveCell.Text = “#N/D” Then ActiveCell = “”
End Sub

=> Ordina dati in decrescente
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

=> Trova dati uguali
Sub CercaeTrova()
Dim Righetot As Integer
Dim Riga As Integer
Dim Riga1 As Integer
Dim RigaCodice As Integer
With ActiveSheet
RigaCodice = 1
Righetot = .[A1].End(xlDown).Row
For Riga = 1 To Righetot
For Riga1 = 1 To Righetot
If .Cells(Riga1, 2).Value = .Cells(Riga, 1).Value Then
.Cells(RigaCodice, 3).Value = .Cells(Riga, 1).Value
RigaCodice = RigaCodice + 1
End If
Next
Next
End With
End Sub

=> Togliere gli spazi in una stringa
Sub ToglieSpazi()
Dim MioValore
Dim X As String, CL As Object
Range(”H2″).End(xlDown).Offset(0, 1).Select
Riga = ActiveCell.Row ‘ trova l’ultima riga della tabella
For Colonna = 8 To 9 ‘ fà un ciclo su 2 colonne
Set MioIntervallo = Range((Cells(2, Colonna)), (Cells(Riga, Colonna))) ‘trovo l’intervallo di celle
For Each CL In MioIntervallo
A1 = Trim(CL) ‘ tolgo gli spazi all’inizio ed alla fine della stringa
CL.Value = A1 ‘ sostituisce la vecchia stringa con la nuova
Next CL
Next Colonna
End Sub

=> Crea un file txt
Sub messaggio()
Sheets.Add
ActiveSheet.Move
Dim MiaUn As String
MiaUn = Left(CurDir, 3)
ActiveWorkbook.SaveAs Filename:=MiaUn & “Messaggio”, FileFormat:=xlTextMSDOS, CreateBackup:=False
Cells(2, 1) = “Ragione Sociale”
Cells(2, 2) = Application.OrganizationName
Cells(3, 1) = “e-mail”
Cells(4, 1) = “telefono”
Cells(4, 2) = “quello che vuoi”
Cells(6, 2) = “altri dati, oggetto o quello che vuoi”
Cells(7, 2) = “testo del messaggio”
Cells(8, 2) = “altro testo”
Cells(9, 2) = “ancora testo”

ActiveWindow.Zoom = 85
Columns(1).ColumnWidth = 18
Columns(2).ColumnWidth = 50
Columns(3).ColumnWidth = 50
Range(”B3:B4″).Select
Selection.Font.Size = 16
Selection.Interior.ColorIndex = 34
Selection.Locked = False
ActiveWindow.DisplayGridlines = False
ActiveWindow.DisplayHeadings = False
ActiveSheet.Protect DrawingObjects:=True, Contents:=True, Scenarios:=True
End Sub

=> Proteggi e sproteggi tutti i fogli
Sub Proteggere()
Dim alex As Integer
alex = ActiveWorkbook.Sheets.Count
Application.ScreenUpdating = False
For i = 1 To alex
Worksheets(i).Protect , password:=”blabla”
Next i
End Sub

Sub sproteggere()
Dim alex As Integer
alex = ActiveWorkbook.Sheets.Count
Application.ScreenUpdating = False
For i = 1 To alex
Worksheets(i).Unprotect , password:=”blabla”
Next i
End Sub

=> Verifica se un dato inserito esiste già
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

=> Mostra tutti i fogli della cartella aperta
Sub ScorreFogli()
For i = 1 To Worksheets.Count
With Worksheets(i)
.Activate
MsgBox .Name
End With
Next
End Sub

=> Macro per selezionare tutti i fogli di una cartella
Sub SelezionaIFogli()
Dim myarray()
ReDim myarray(1 To ActiveSheet.Index)
For i = 1 To ActiveSheet.Index
myarray(i) = i
Next i
Worksheets(myarray).Select
End sub