| |
Numero esempio :
1
Titolo : Sopprimere_il_codice_di_protezione_del_foglio
Autore : Remi
Commento : Attenzione, con piu di tre carattere, il tempo per
trovare il codice diventa lunghissimo !!!
For a = 1 To 250
On Error Resume Next
AppExcel.ActiveSheet.Unprotect (Chr(a))
Next
For a = 1 To 250
For b = 1 To 250
On Error Resume Next
AppExcel.ActiveSheet.Unprotect (Chr(a) & Chr(b))
Next
Next
Numero esempio :
2
Titolo : Visualizzare_un_documento_PDF
Autore : Remi
Commento : Una macro per vedere un file PDF attraverso Excel.
Private Sub
CommandButton1_Click()
ActiveWorkbook.FollowHyperlink Address:="c:
oto.pdf"
End Sub
Numero esempio :
3
Titolo :
Come_fare_riferimento_alla_cellula_A2_da_partire_dela_cella_A1
Autore : Remi
Commento : Che tre possibilita :
Range("a1").offset(1,0)
Range("A1").offset(1)
Range("A1")(2)
Numero esempio :
4
Titolo : Trovare_la_prima_cella_vuota
Autore : Remi
Commento : Una macro che va alla prima cella vuota.
Sub ultima_cella()
If Range("A1").Value = "" Then
Range("A1").Select
Else
If Range("A1").Value <> "" And
Range("A2").Value = "" Then
Range("A2").Select
Else:
Worksheets("Foglio2").Range("A1").End(xlDown).Offset(1, 0).Select
End If
End If
End Sub
Numero esempio :
5
Titolo : Conoscere_il_numero_della_riga_o_della_colonna
Autore : Remi
Commento : Una mcro semplice per conoscere il numero della riga o
della colonna.
sub riga/colonna()
riga = activecell.row
colonna = activecell.column
msgbox (riga, colonna)
End sub
Numero esempio :
6
Titolo : Avviare_una_macro_mentre_il_file_si_apri
Autore : Remi
Commento : Mettere la macro dopo
Private Sub Workbook_Open()
Numero esempio :
7
Titolo : Avviare_una_macro_una_volta_sola
Autore : Remi
Commento : Una macro che si avvia una volta sola. Alla fine della
macro, la procedura è cancellata.
Private Sub Workbook_Open()
Dim liDeb, NbLi
'avvia
la macro
Msg = "La procedura Workbook_Open e terminata
"
ActiveSheet.Range("A1").Value = Msg
'elimina la macro
With ThisWorkbook.VBProject.VBComponents("ThisWorkbook").CodeModule
liDeb = .ProcStartLine("Workbook_Open", 0)
NbLi = .ProcCountLines("Workbook_Open", 0)
.DeleteLines liDeb, NbLi
End With
End Sub
Numero esempio :
8
Titolo : Avviare_una_macro_con_un_click_su_una_cella
Autore : Remi
Commento : Una macro per avviare un'altra macro facendo un clic su
una cella scelta.
Private Sub
Worksheet_SelectionChange(ByVal Target As Range)
If Target.Address = "$A$1" Then MsgBox "forza
!" 'Macro1
End Sub
Numero esempio :
9
Titolo : Come_Visualizzare_/_nascondere_un_userform
Autore : Remi
Commento : Degli esempi per sapere come visualizzare / nascndere un'userform.
'Per
attivare un userform senza lo visualizzare
Load UserForm
'Per
visualizzare un userform
UserForm.show
'Per
nascondere un userform
UserForm.hide
Numero esempio :
10
Titolo : Aprire_una_macro_se_un_userform_e_aperto
Autore : Remi
Commento : Una macro per avviare un'altra macro se un userform è
visibile.
sub userformvisibile()
If UserForm1.Visible = True Then
MsgBox "buongiormo" 'Macro1
Else MsgBox "arrivederci" 'Macro2
End If
end sub
Numero esempio :
11
Titolo : Scegliere_una_cella_con_casella_combinata
Autore : Remi
Commento : Un macro che permette di selezionare una cella attraverso
una casella combinata.
Private Sub
CommandButton1_Click()
Dim dest As String
If ComboBox1.Value = "C3" Then
dest = "A1"
End If
If ComboBox1.Value = "C5" Then
dest = "A2"
End If
If ComboBox1.Value = "C10" Then
dest = "A3"
End If
Range(dest).Select
End Sub
Private Sub UserForm_Initialize()
ComboBox1.AddItem "C3"
ComboBox1.AddItem "C5"
ComboBox1.AddItem "C10"
End Sub
Numero esempio :
12
Titolo : Dividire_campi_con_delle_virgule
Autore : Remi
Commento : Una macro che divide i campi separati di una virgola.
Eguale a
Dati => Testo in colonna.
Sub Dividirecampi()
Sheets("Feuil1").Select
Range("A1:A10").Select
Selection.Copy
Sheets("Feuil2").Select
ActiveSheet.Paste
Range("a1:a10").Select
Application.CutCopyMode = False
Workbooks("classeur1.xls").Sheets(Feuil2).Cells(1, 1).Value. _
TextToColumns
Destination:=Workbooks("classeur1.xls").Sheets(Feuil2).Cells(2, 2),
DataType:=xlDelimited, _
TextQualifier:=xlDoubleQuote,
ConsecutiveDelimiter:=False, Tab:=False, _
Semicolon:=False, Comma:=True, Space:=False,
Other:=False
End Sub
Numero esempio :
13
Titolo : Accesso_ai_filtri_con_la_protezione_della_foglia
Autore : Remi
Commento : Una macro per potere accedere ai filtri quando il foglio
è protetto.
Private Sub
Workbook_Open()
Foglio1.EnableAutoFilter = True
Foglio1.Protect Contents:=True,
UserInterfaceOnly:=True
End Sub
Numero esempio :
14
Titolo : Eliminare_celle_vuote
Autore : Remi
Commento : Due macro. La prima cancella solo le celle invece la
seconda cancella la riga intera.
'Per
eliminare solo le celle :
Sub elimina celle vuote()
Range("A:A").SpecialCells(xlCellTypeBlanks).Delete (xlShiftUp)
End Sub
'Per
eliminare la riga completa :
Sub elimina riga si cella vuota()
Range("A:A").SpecialCells(xlCellTypeBlanks).EntireRow.Delete
End Sub
Numero esempio :
15
Titolo : Annulare_sempre_azione
Autore : Remi
Commento : Con questa macro, non si può scrivere niente.
Ogni operazione
è subitò annulata.
Private Sub
Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range)
Application.EnableEvents = False
Application.Undo
Application.EnableEvents = True
End Sub
Numero esempio :
16
Titolo : Avviare_macro_spingendo_un_tasto
Autore : Remi
Commento : Una macro si avvia quando una personna preme un tasdto,
qualche sia.
Private Sub
Workbook_Activate()
For i = 1 To 250
On Error Resume Next
Application.OnKey Chr(i), "Macro1"
Next i
Numero esempio :
17
Titolo : Inserire_commento_con_formato_diverso
Autore : Remi
Commento : Una macro per inserire un commento con un formato diverso
dello standard.
Sub Inserire
commento()
With
ActiveCell.AddComment.Shape.OLEFormat.Object
.Text = ""
.Font.Name = "Times New Roman"
.Font.Size = 14
End With
SendKeys "%IM"
ActiveCell.Comment.Visible = True
ActiveCell.Comment.Shape.Select True
End Sub
Numero esempio :
18
Titolo :
Cambiare_il_valore_della_combobox2_quando_la_combobox1_è_cambiata
Autore : Remi
Commento : Una macro che collega due combobox.
Private Sub
ComboBox1_Click()
For Each i In [A1:A100]
If i Like ComboBox1.Value Then
i.Select
ComboBox2.Value =
ActiveCell.Offset(0, 1)
Exit Sub
End If
Next
End Sub
'o
Private Sub ComboBox1_Change()
Userform1.ComboBox2.ListIndex =
Userform1.ComboBox1.ListIndex
End Sub
Numero esempio :
19
Titolo : Disattivare_o_attivare_un_controllo_nel_menu_Excel
Autore : Remi
Commento : Une esempio per disattivare un controllo nella barra del
menu Excel.
Sub test()
Application.CommandBars(1).Controls("File"). _
Controls("Salva").Enabled = False
End Sub
Numero esempio :
20
Titolo : Avviare_una_macro_a_un'ora_definita
Autore : Remi
Commento : Una macro che fa un' azione ad una precisa, usando la
funzione Ontime.
Private Sub Workbook_Open()
Application.OnTime TimeValue("22:00:00"),
"Macro1"
End Sub
Numero esempio :
21
Titolo : Dare_accesso_a_un_parte_del_foglio_secondo_l'utente
Autore : Remi
Commento : Una macro che permette di dare la possibilità di scrivere
o non nelle celle di una zona, secondo l'utente Excel.
Private Sub
Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range)
Dim name As String
name = Application.UserName
If name = "Utente 1" Then
If Intersect(Target, Range("A:A")) Is
Nothing Then
MsgBox "Vietato accesso"
Application.EnableEvents = False
Application.Undo
Application.EnableEvents = True
End If
End If
If name = "Utente 2" Then
If Intersect(Target, Range("B:B")) Is
Nothing Then
MsgBox "Vietato accesso"
Application.EnableEvents = False
Application.Undo
Application.EnableEvents = True
End If
End If
If name = "Utente 3" Then
If Intersect(Target, Range("C:C")) Is
Nothing Then
MsgBox "Vietato accesso"
Application.EnableEvents = False
Application.Undo
Application.EnableEvents = True
End If
End If
If name = "Utente 4" Then
If Intersect(Target, Range("D:D")) Is
Nothing Then
MsgBox "Vietato accesso"
Application.EnableEvents = False
Application.Undo
Application.EnableEvents = True
End If
End If
End Sub
Numero esempio :
22
Titolo : Chiudere_una_form_dopo_cinque_secondi
Autore : Remi
Commento : Una macro che chiude un' userform dopo, per esempio,
cinque secondi.
'Per la Form
Private Sub UserForm_Activate()
Application.OnTime Now +
TimeValue("00:00:5"), "chiude"
End Sub
Private Sub UserForm_Initialize()
Label1.Caption = "Active sheet: " &
ActiveWorkbook.ActiveSheet.Name
End Sub
Private Sub CommandButton1_Click()
UserForm1.Hide
End Sub
' E nel Module1 del
workbook
Sub chiude()
UserForm1.Hide
End Sub
Numero esempio :
23
Titolo : Accesso_+_e_-_dell'opzione_Ragruppa
Autore : Remi
Commento : Una macro che permette di usare l'opzione
Ragruppa-Struttura quando il foglio è protetto.
Private Sub Workbook_Open()
ActiveSheet.EnableOutlining = True
End Sub
Numero esempio :
24
Titolo : Selezionnare_celle_se_celle=celleA1
Autore : Tiziano Marmiroli
Commento : Selezionare una zona se il valore di una cella di una
zona è eguale al valore della cella A1.
Dim i As Integer
For i = 4 To 150
If [A1].Value = Range("A" & i).Value Then
Range("B" & i & ":" & "AF" & i).Select
End If
Next
Numero esempio :
25
Titolo : Scrivere_nel_file_txt
Autore : cucchiaino
Commento : Una macro semplice per scrivere in un file TXT.
Sub scrivi()
Open "C\:prova.txt" For Output As #1
r = 1
Print #1, "Nel magazzino ho:"
While Cells(r, 1) <> ""
Print #1, Cells(r, 2); " "; Cells(r, 1)
r = r + 1
Wend
Close #1
End Sub
Numero esempio :
26
Titolo : Tenire_il_formato_di_una_cella_per_un_listbox
Autore : Mauro Gamberini
Commento : Una macro che permette di tenire il formato della cella
per riempire una listbox.
ListBox1.AddItem
(Format(Foglio1.Range("A1").Value, "e #,###.00"))
Numero esempio :
27
Titolo : Avviare_macro_diversa_secondo_la_cella
Autore : Tiziano Marmiroli
Commento : Permette di mandare una macro diversa seconda la cella
selezionata.
Sub Prova()
Dim R As Range
On Error Resume Next
Set R = Range("A1:A4")
For i = 1 To R.Cells.Count
If R.Cells(i).Value < -0.01 Or
R.Cells(i).Value > 0.01 Then
Application.Run ("Modulo1.Pippo" & i)
End If
Next i
End Sub
Sub Pippo1()
MsgBox ("Questa e la macro pippo1")
End Sub
Numero esempio :
28
Titolo : Valore_non_presente_in_una_zona
Autore : cucchiaino
Commento : Una macro che permette d'individure se un valore è
presente in una zona de cella, e apre un messagio se nessuno valore
è stato trovato.
Sub macro1()
x = Val(TextBox19.Text)
If IsError(Application.Match(x,
Range("A1:A100"), 0)) Then
Beep
MsgBox "Numero non presente in elenco!"
else
MsgBox "Numero presente in elenco, alla riga:
" & Application.Match(x,Range("A1:A100"), 0)
End If
End sub
Numero esempio :
29
Titolo : Avviare_macro_quando_cella_A3000_è_riempita
Autore : Ignazio
Commento : Una macro che permette di avviare un'altra macro quando
una cella è selezionata.
Private Sub
Worksheet_Change(ByVal Target As Range)
If Target.Address = "$A$3000" Then pippo
End Sub
Numero esempio :
30
Titolo : Non_vedere_l'azione_della_macro_fino_alla_fine
Autore : Remi
Commento : Un trucco per non vedere le modifiche di una macro fino
alla fine dell'esecuzione della macro.
Public Sub Macro1()
Application.ScreenUpdating = False
'
' qui il tuo codice
'
Application.ScreenUpdating = True
End Sub
Numero esempio :
31
Titolo : formato_listbox
Autore : Mauro Gamberini
Commento : Cambiare il formato delle caratteri dell'elenco di una
ListBox.
ListBox1.Font.Name =
"Courier New"
ListBox1.Font.Italic = True
ListBox1.Font.Size = 20
Numero esempio :
32
Titolo : Spedire_un_email_con_excel
Autore : Remi
Commento : Un codice per mandare la cartella attiva via email.
ActiveWorkbook.SendMail
Recipients:="nome@aol.com"
Numero esempio :
33
Titolo : TextBox_con_valore_all_apertura_dell_userform
Autore : Remi
Commento : Permette di riempire una textbox all'apertura
dell'userform con il valore di una cella.
Private Sub
UserForm_Initialize()
TextBox1.Value = Range("A1").Value
TextBox2.Value = Range("B1").Value
End Sub
Numero esempio :
34
Titolo : Impedire_l'apertura_della_barra_web
Autore : Remi
Commento : Copiare ed incollare queste macro nel workbook in cui
volete impedire l'apertura della barra web.
Private Sub
Workbook_Close()
On Error Resume Next
Application.CommandBars("Web").Enabled = True
End Sub
Private Sub Workbook_Open()
On Error Resume Next
Application.CommandBars("Web").Enabled = False
End Sub
Numero esempio :
35
Titolo : Spedire_un_mail_con_excel_e_Microsoft_Outlook
Autore : Didier Cannesson
Commento : Permette di mandare un email attraverso microsoft outlook
'fa riferimento a Outlook Application
'fare nel VBA : Strumenti => riferimenti
e selezionare Microsoft Outlook Object Library
Sub spedire()
Dim OlApp As New Outlook.Application
'riferimento a un Oggetto E-Mail nel Outlook
Dim myMailItem As Outlook.MailItem
'creazione ...
Set OlApp =
CreateObject("Outlook.Application")
Set myMailItem = OlApp.CreateItem(olMailItem)
With myMailItem
'Soggetto
.Subject = "Soggetto"
'allegato
.Attachments.Add "C:\prova.xls"
'destinatario della mail
.To = "masremi@aol.com"
'corpo del messaggio
.Body = "Corps du message"
'mettere l'indirizzo email del mittente (deve
essere presente nei contatti)
.SentOnBehalfOfName = "masremi@aol.com"
'spedisce
.Send
End With
'destruzione del riferimento
Set OlApp = Nothing
End Sub
Numero esempio :
36
Titolo : Mettere_una_formula_nella_cella
Autore : Tiziano Marmiroli
Commento : Se usate la proprietà Formula, la formula deve esser in
inglese, se usate la proprietà FormulaLocal, la formula deve essere
nella lingua del vostro Excel.
Worksheets("foglio2").Range("D6").Formula=("=SUM(a20:c20)")
'o
Worksheets("foglio2").Range("D6").FormulaLocal=("=SOMMA(a20:c20)")
Numero esempio :
37
Titolo : Cambiare_l'opzione_di_mossa_per_un_foglio
Autore : Remi
Commento : Permette di cambiare il senso del movimento del cursore
dopo l'invio.
Eguale a : Strumenti => opzioni => Modifica => Sposta la selezione
dopo l'invio
Private Sub Worksheet_Activate()
Application.MoveAfterReturnDirection =
xlToRight
End Sub
Private Sub Worksheet_Deactivate()
Application.MoveAfterReturnDirection = xlDown
End Sub
Numero esempio :
38
Titolo : Un_numero_su_una_textbox
Autore : MAO
Commento : Vietare tutte le caratteri trane i numeri pzer riempire
una TextBox
Private Sub TextBox3_KeyPress(ByVal
KeyAscii As MSForms.ReturnInteger)
Const Numbers$ = "0123456789,"
If KeyAscii <> 8 Then
If InStr(Numbers, Chr(KeyAscii)) = 0 Then
KeyAscii = 0
End If
End If
End Sub
Numero esempio :
39
Titolo : Ridurre_finistra
Autore : Mauro Gamberini
Commento : Dovete copiare il codice nel Workbook in cui volete
ridurre la finestra, così all'apertura, la finestra sarà sempre
piccola.
Private Sub
Workbook_BeforeClose(Cancel As Boolean)
ßßß ActiveWindow.WindowState = xlMaximized
End Sub
Private Sub Workbook_Open()
ßßß ActiveWindow.WindowState = xlMinimized
End Sub
Numero esempio :
40
Titolo : Conoscere_Indirizzo_della_cella
Autore : LL, mpfe
Commento : Permette di avere l'indirizzo completo della cella in cui
è scritto la funzione.
Utilissimo per le proprietà ListFillRange e RowSource degli oggetti
Combobox e ListBox.
Function Lamiacella() As String
'Ritorna l'indirizzo della cella dove e
scritta la funzione
(Nel foglio di calcolo)
Lamiacella = "L'indirizzo completo della cella
è : " & _
Application.Caller.Address(0, 0, , 1) 'A
ddress(External:=True)
End Function
Numero esempio :
41
Titolo : Indirizzo_cella_in_cui_c_e_la_parola_cercata
Autore : Chip Pearson, mpep
Commento : Modifica => Trova va alla cella, questa funzione vi da
l'indirizzo della cella.
Ritorna l'indirizzo della cella in cui c'è una parola in una zona.
Function
AddressOfWord(WhatWord As String) As String
'Chip Pearson, mpep
Dim Rng As Range
"For Each Rng In Range(""A1:M100"")"
If InStr(1, Rng.Text, WhatWord, vbT ext Com
pare) <> 0 Then
AddressOfWord = Rng.Address
Exit Function
End If
Next Rng
End Function
Sub test()
"' MsgBox AddressOfWord(""fred"")"
" MsgBox AdresseMot(""fred"")"
End Sub
Function AdresseMot(Mot As String)
'Dana DeLouis, mpep
Dim strAddress As String
On Error Resume Next
" With Columns(""A:M"")"
AdresseMot = .Find( _
What:=Mot, _
After:=.Cells(.Cells.Count), _
LookIn:=xlValues, _
LookAt:=xlPart, _
SearchDirection:=xlNext, _
MatchCase:=False).Address
End With
End Function
Numero esempio :
42
Titolo : adattare_la_taglia_delle_celle_unite
Autore : Jim Rech, mpep
Commento : Adattare automaticamente la taglia della riga delle celle
unite
la macro e stata creata per agire sulle celle unite
sulla stessa riga (o con l'aiuto del pulsante "centrare su parecchie
colonne").
Sub
AutoFitMergedCellRowHeight()
Jim Rech, mpep
Dim CurrentRowHeight As Single,
MergedCellRgWidth As Single
Dim CurrCell As Range
Dim ActiveCellWidth As Single,
PossNewRowHeight As Single
If ActiveCell.MergeCells Then
With ActiveCell.MergeArea
.WrapText = True 'crea un invio automatico
(modifica fs)
If .Rows.Count = 1 Then 'And .WrapText = True
Then
Application.ScreenUpdating = False
CurrentRowHeight = .RowHeight
ActiveCellWidth = ActiveCell.ColumnWidth
For Each CurrCell In Selection
MergedCellRgWidth = CurrCell.ColumnWidth + _
MergedCellRgWidth
Next
.MergeCells = False
.Cells(1).ColumnWidth = MergedCellRgWidth
.EntireRow.AutoFit
PossNewRowHeight = .RowHeight
.Cells(1).ColumnWidth = ActiveCellWidth
.MergeCells = True
.RowHeight = IIf(CurrentRowHeight >
PossNewRowHeight, _
CurrentRowHeight, PossNewRowHeight)
End If
End With
End If
End Sub
Numero
esempio : 43
Titolo : Nascondere_righe_doppie
Autore :
Commento : Cerca e nasconde le righe doppie
Sub
Nascondere_righe_doppie()
Dim cell As Range, CellsToHide As Range, derLi
As Long
Application.ScreenUpdating = False
derLi = Cells(Rows.Count, 1).End(xlUp).Row
For i = derLi To 2 Step -1
If Not IsError(Application.Match(Cells(i,
1).Value, _
Range("A1:A" & i - 1), 0)) Then
If CellsToHide Is Nothing Then
Set CellsToHide = Cells(i, 1)
Else: Set CellsToHide = Union(CellsToHide,
Cells(i, 1))
End If
End If
Next i
If Not CellsToHide Is Nothing Then _
CellsToHide.EntireRow.Hidden = True
End Sub 'fs
Numero esempio :
44
Titolo : Fare_lampeggiare_una_cella2
Autore : Bill Manville
Commento : Fare lampeggiare una cella usando la proprietà : stile
Per creare una cella che lampeggia
Dovete definire un nuovo stile (formato / stile / lampeggia /
Aggiungi)
Impore questo stile per le celle che volete fare "lampeggiare", ed
incollate il codice seguente
in un modulo foglio ed avviate la procedura "lampeggio" dal
luogo dove volete che il testo lampeggia in bianco e rosso
Bill Manville
Dim NextTime As Date
Sub lampeggia()
NextTime = Now + TimeValue("00:00:01")
With ActiveWorkbook.Styles("lampeggia").Font
If .ColorIndex = 2 Then .ColorIndex = 3 Else
.ColorIndex = 2
End With
Application.OnTime NextTime, "lampeggia"
End Sub
Sub StopIt()
Application.OnTime NextTime, "lampeggia",
schedule:=False
ActiveWorkbook.Styles("Flash").Font.ColorIndex
= xlAutomatic
End Sub
Numero esempio :
45
Titolo : Fare_lampeggiare_una_cella3
Autore : Alain Vallon, mpfe
Commento : Se volete fare lampeggiare una cella o una zone, dovete
usare il VBA !
Un
esempio particolare per fare lampeggiare la zona A1:D10
'Private Sub
Worksheet_Change(ByVal Target As Range)
' If Not Intersect(Target, Range("A1:D10")) Is
Nothing Then CLIGNOTE
' Target.Select
'End Sub
Nel modulo normale
Declare Sub Sleep Lib "kernel32" (ByVal
dwMilliseconds A s Long)
Sub CLIGNOTE()
Alain Vallon, mpfe
[A1:D10].Find _
(What:=Application.WorksheetFunction.Min([A1:D10]), LookAt:=x lW
hole).Activate
memo1 = ActiveCell.Font.ColorIndex
memo2 = ActiveCell.Font.Size
For x = 1 To 5
For i = 10 To 20
ActiveCell.Font.ColorIndex = 3
ActiveCell.Font.Size = i
Sleep (5)
DoEvents
Next i
ActiveCell.Font.Size = 12
ActiveCell.Font.ColorIndex = 1
Next x
ActiveCell.Font.ColorIndex = memo1
ActiveCell.Font.Size = memo2
End Sub
Numero esempio :
46
Titolo : Fare_lampeggiare_una_cella4
Autore : Michel Pierron, mpfe
Commento : Per fare lampeggiare una cella...
Sub Lampeggiacella()
Michel Pierron, mpfe
Const Texte As String = "Flashing cell..."
Dim i As Integer
For i = 1 To 10
Cells(1, 1) = Texte
Call Flash_Sequence
Next i
End Sub
Private Sub Flash_Sequence()
Dim n As Byte, Start As Variant
For n = 1 To 10
Start = Timer
Do While Timer < Start + 1 / 100
Loop
If n Mod 5 = 0 Then Cells(1, 1) = ""
Next n
End Sub
Numero
esempio : 47
Titolo : Fare_lampeggiare_una_cella
Autore : Laurent Mort?zai, mpfe
Commento : la macro permette di fare lampeggiare la cella attiva
Ogni secondi
Comminciando il lampeggio avviando InitFlash
Laurent Mortezai, mpfe
(prevedere una procedura per fermare il lampeggio -fs)
'======Nel un modulo
normale
Public OrigBkgCol As Long, OrigTxtCol As Long
Public OldCell As Range
Sub InitFlash()
Set OldCell = ActiveCell
OrigBkgCol = ActiveCell.Interior.ColorIndex
OrigTxtCol = ActiveCell.Font.ColorIndex
Application.OnTime Now +
TimeValue("00:00:01"), "Flash"
End Sub
Sub Flash()
If ActiveCell.Interior.ColorIndex < 0 Then
ActiveCell.Interior.ColorIndex = 1 'colore
fondo nero
ActiveCell.Font.ColorIndex = 2 'colore testo
bianco
Else
ActiveCell.Interior.ColorIndex =
(ActiveCell.Interior.ColorIndex + 1) Mod 2
ActiveCell.Font.Color = 1
End If
Application.OnTime Now +
TimeValue("00:00:01"), "Flash"
End Sub
=======A copiare nel visual basic editor, nel
foglio
dove desiderate fare lampeggiare una cella
Private Sub Worksheet_SelectionChange(ByVal
Target As Range)
' On Error GoTo zut
' OldCell.Interior.ColorIndex = OrigBkgCol
' OldCell.Font.ColorIndex = OrigTxtCol
' OrigBkgCol = Target.Interior.ColorIndex
' OrigTxtCol = Target.Font.ColorIndex
' Set OldCell = Target
'zut:
'End Sub
Numero esempio :
48
Titolo : Fare_lampeggiare_una_cella_con_una_condizione
Autore : Alain Vallon, mpfe
Commento : Se volete fare lampeggiare, dovete usare il VBA !
Un
esempio per fare lampeggiare la zona A1:D10
'Private Sub
Worksheet_Change(ByVal Target As Range)
' If Not Intersect(Target, Range("A1:D10")) Is
Nothing Then CLIGNOTE
' Target.Select
'End Sub
Nel un modulo normale
Declare Sub Sleep Lib "kernel32" (ByVal
dwMilliseconds A s Long)
Sub CLIGNOTE()
Alain Vallon, mpfe
[A1:D10].Find _
(What:=Application.WorksheetFunction.Min([A1:D10]), LookAt:=x lW
hole).Activate
memo1 = ActiveCell.Font.ColorIndex
memo2 = ActiveCell.Font.Size
For x = 1 To 5
For i = 10 To 20
ActiveCell.Font.ColorIndex = 3
ActiveCell.Font.Size = i
Sleep (5)
DoEvents
Next i
ActiveCell.Font.Size = 12
ActiveCell.Font.ColorIndex = 1
Next x
ActiveCell.Font.ColorIndex = memo1
ActiveCell.Font.Size = memo2
End Sub
Numero
esempio : 49
Titolo : Sapere_se_le_celle_di_una_zona_sono_vuote
Autore : Dana DeLouis, mpep
Commento : Sapere se le celle di una spiaggia sono vuote o non
Sub
CheckForEmptyCells()
Dana DeLouis, mpep
With [A1:Z100]
n = Application.CountBlank(.Cells)
If .Cells.Count = n Then
MsgBox "La cella e vuota"
ElseIf n = 0 Then
MsgBox "Cella piena"
Else
MsgBox "Solo alcune celle sono vuote"
End If
End With
End Sub
Ritorna l'indirizzo della prima cella vuota
della colonna
Sub Primacellavuota()
'Tom Ogilvy, mpep
Dim rng As Range
prova la colonna A
Set rng = Range(Cells(1, 1), Cells(Row s.C oun
t, 1).End(xlUp))
On Error Resume Next
Set rng = rng.SpecialCells(xlBlanks)
On Error GoTo 0
If Not rng Is Nothing Then
MsgBox rng(1, 1).Address
Else
MsgBox "Non ci sono delle celle vuote"
End If
End Sub
Numero esempio :
50
Titolo : cercare_cella_con_formattazione_condizionale
Autore : L Longre, mpfe
Commento : Per sapere il numero di celle rosse sapendo che
il colore e una formattazione condizionale
(non posso contare il numero di celle rispondando alla condizione !)
Sub FormatCondi()
L Longre, mpfe
Dim FC As FormatCondition, F1, F2
For Each FC In ActiveCell.FormatConditions
If FC.Type = xlCellValue Then
F1 = Evaluate(FC.Formula1)
Select Case FC.Operator
Case xlBetween: If ActiveCell >= F1
And ActiveCell <= Evaluate(FC.Formula2) Then
Exit For
Case xlEqual: If ActiveCell = F1 Then Exit For
Case xlGreater: If ActiveCell > F1 Then Exit
For
Case xlGreaterEqual: If ActiveCell >= F1 Then
Exit For
Case xlLess: If ActiveCell < F1 Then Exit For
Case xlLessEqual: If ActiveCell <= F1 Then
Exit For
Case xlNotBetween: If ActiveCell < F1 _
Or ActiveCell > Evaluate(FC.Formula2) Then
Exit For
Case xlNotEqual: If ActiveCell <> F1 Then Exit
For
End Select
Else
If Evaluate(FC.Formula1) Then Exit For
End If
Next FC
If Not FC Is Nothing Then MsgBox
FC.Interior.ColorIndex _
Else MsgBox ActiveCell.Interior.ColorIndex
End Sub
Numero
esempio : 51
Titolo : Sapere_Colore_se_formatto_condizionale
Autore : L Longre
Commento : Ritorna l'indice della colore del fondo dela cella
Questo colore dipende della mise in formatto condizionale
Sub
qual_e_la_colore_del_fondo_se_formatto_condzionale()
L Longre
Dim FC As FormatCondition, F1, F2
For Each FC In ActiveCell.FormatConditions
If FC.Type = xlCellValue Then
F1 = Evaluate(FC.Formula1)
Select Case FC.Operator
Case xlBetween: If ActiveCell >= F1
And ActiveCell <= Evaluate(FC.Formula2) Then
Exit For
Case xlEqual: If ActiveCell = F1 Then Exit For
Case xlGreater: If ActiveCell > F1 Then Exit
For
Case xlGreaterEqual: If ActiveCell >= F1 Then
Exit For
Case xlLess: If ActiveCell < F1 Then Exit For
Case xlLessEqual: If ActiveCell <= F1 Then
Exit For
Case xlNotBetween: If ActiveCell < F1 _
Or ActiveCell > Evaluate(FC.Formula2) Then
Exit For
Case xlNotEqual: If ActiveCell <> F1 Then Exit
For
End Select
Else
If Evaluate(FC.Formula1) Then Exit For
End If
Next FC
If Not FC Is Nothing Then MsgBox
FC.Interior.ColorIndex _
Else MsgBox ActiveCell.Interior.ColorIndex
End Sub
Numero
esempio : 52
Titolo : paragonare_colonna_A_e_colonna_B_3
Autore : Tom Ogilvy, mpep
Commento : Paragona le colonne A e B
Scrive nella colonna C i valori della colonna B
che non sono nella colonna A
Usa la funzione NB.SE
Sub ParagonaAeB()
Tom Ogilvy, mpep
Dim rngA As Range
Dim rngB As Range
Dim rw As Long
Set rngA = Range(Cells(1, 1), Cells(Rows.C ou
nt, 1).End(xlUp))
Set rngB = Range(Cells(1, 2), Cells(Rows.C ou
nt, 2).End(xlUp))
rw = 1
For Each cell In rngB
If Application.CountIf(rngA, cell.Value) = 0
Then
Cells(rw, 3).Value = cell.Value
rw = rw + 1
End If
Next
End Sub
Numero
esempio : 53
Titolo : paragonare_colonna_A_e_colonna_B_2
Autore : Dana DeLouis & RB Smissaert, mpep
Commento : paragona i valori di due colonne
(stesso numero di righe)
Sub
CompareLists_V2()
Dana DeLouis & RB Smissaert, mpep
'prima tutto dovete selezionnare due colonne
come range
Dim i As Long
Dim ListA As Variant
Dim ListB As Variant
Dim ListC() As String
Dim Count As Long
ListA = Selection.Areas(1)
ListB = Selection.Areas(2)
Count = UBound(ListA)
ReDim ListC(1 To Count, 1 To 1)
For i = 1 To Count
'(attenzione ai caratteri maiusculi e
munisculi)
If StrComp(ListA(i, 1), ListB(i, 1),
vbBinaryCompare) = 0 Then
ListC(i, 1) = "Same"
Else
ListC(i, 1) = "Diff"
End If
Next
Dim P As Range
On Error Resume Next
Set P = Application.InputBox( _
prompt:="SELECT A CELL", _
Title:=" COMPARE LISTS", _
Type:=8)
If P Is Nothing Then Exit Sub
With P
Cells(.Row, .Column).Resize(Count) = ListC
End With
End Sub
Numero esempio :
54
Titolo : paragonare_colonna_A_e_colonna_B
Autore : John Topley, mpep
Commento : Paragona le colonne A e B e scrive 0 nella colonna C
quando
un valore nella colonna A si trova anche nella colonna B
' Usa la funzione Match (Equiv) per trovare
i datidella colonna A che sono anche nella colonna B.
Sub CompareTwoColumns()
Dim rngA As Range
Dim rngB As Range
Set rngA = Range(Cells(1, "A"),
Cells(Rows.Count, "A ").End(xlUp))
Set rngB = Range(Cells(1, "B"),
Cells(Rows.Count, "B ").End(xlUp))
For Each cell In rngA
If Not IsError(Application.Match(cell.Value,
rn gB, 0)) Then
Cells(cell.Row, "C").Value = 0
End If
Next
End Sub
Numero
esempio : 55
Titolo : Contare_numero_di_lettere
Autore : AV, mpfe
Commento : contare il numero di occorenza di u na lettera in ogni
celle
di una zona di celle
Sub conta()
'AV, mpfe
For Each cel In Range("A7:X7")
For i = 1 To Len(cel)
If Mid(cel, i, 1) = "A" Then cpt = cpt + 1
Next
Next
MsgBox cpt
End Sub
Function NbLettres(plage As Range, L ettre$, _
Optional Casse As Boolean = True)
'fs, mpfe
Dim cell As Range
NbLettres = 0
For Each cell In plage
If Not cell.Text = "" Then
If Casse = False Then
NbLettres = NbLettres + UBound(Split(L Ca
se(cell.Text), LCase(Lettre)))
Else
NbLettres = NbLettres + UBou nd(Split(c el
l.Text, Lettre))
End If
End If
Next
End Function
Function NbreLettres(laPlage As Rang e,
laLettr e As String, laCasse As Boolean)
'AV, mpfe
Dim cel As Range
For Each cel In laPlage
For i = 1 To Len(cel)
If laCasse = True Then If Mid( cel, i, 1) =
laLettre Then _
NbreLettres = Nbr eLett res + 1
If laCasse = False Then
If Mid(cel, i, 1) = LCa se(la Lettre) Or M
id(cel, i, 1) = laLettre _
Then NbreLettres = Nbr eLettres + 1
End If
Next
Next
End Function
Numero
esempio : 56
Titolo : contare_valori_unichi
Autore :
Commento :
Function
NBValUnichi(zona As Range)
Dim C As New Collection
On Error Resume Next
For Each cell In zona
If cell.Text <> "" Then C.Add "zaza",
cell.Text
Next
Err.Clear
NBValUnichi = C.Count
End Function 'fs
Numero esempio :
57
Titolo : concatenare_celle_con_separatore_scelto
Autore :
Commento : Permette di concatenare le celle scelte separandole di
una sigla a voglia.
'soluzione 1
Function Xconcat(myPlage As Range, Optional
separ)
'Utilisazione della funzione
'Parametre 1 = zona di celle
'Parametre 2 = "separatore (a voglia)"
'ex: Xconcat(A1:C8;"atchoum")
If IsMissing(separ) Then separ = ""
For Each i In myPlage
conc = conc & i & separ
Next
Xconcat = conc
If Len(Xconcat) > 32767 Then
MsgBox "concatenation > 32767 caract / " &
Len(Xconcat)
End If
End Function 'raoul marceau, mpfe
'soluzione 2
Function ConcatenareSeparatore(Zona As Range,
Separatore As String)
Dim Cellule As Range
For Each Cellule In Zona
ConcatenareSeparatore = _
ConcatenareSeparatore & Cellule & Separatore
Next Cellule
ConcatenareSeparatore = _
Left(ConcatenareSeparatore,
Len(ConcatenareSeparatore) - 1)
End Function 'Pierre Fauconnier, mpfe
'soluzione 3
Function JoinCells(Plage As Range, Optio na l
Sep As String = " ")
Dim S$
For i = 1 To Plage.Cells.Count
If Plage(i).Value <> "" Then
S = S & Plage(i).Value & Sep
End If
Next
JoinCells = Left(S, Len(S) - 1)
End Function 'fs
Numero esempio :
58
Titolo : Concatenare_due_colonne
Autore : jps, mpfe
Commento : Permette di concatenare due colonne in una sola.
Sub Concatenare() On Error Resume Next
Dim derniereligne As String
col1 = InputBox("Quale e la colonna (lettere o
numero)" & _
vbLf & "chi servira di resultato e",
"Concatener")
If col1 = "" Then Exit Sub
If IsNumeric(col1) Then
' con l'aiuto di Laurent Mortezai
tmpCol = Chr(((col1 - 1) Mod 26) + 65)
If col1 > 26 Then tmpCol = Chr((col1 - 1) 26 +
64) & tmpCol
col1 = tmpCol
End If
col2 = InputBox("Quale e la colonna (lettere
ou numero)" & _
vbLf & "dove sono presi i valori",
"Concatener")
If col2 = "" Then Exit Sub
If IsNumeric(col2) Then
' idem
tmpCol = Chr(((col2 - 1) Mod 26) + 65)
If col2 > 26 Then tmpCol = Chr((col2 - 1) 26 +
64) & tmpCol
col2 = tmpCol
End If
derniereligne = Range(col1 &
"65536").End(xlUp).Row
For i = 1 To derniereligne
Range(col1 & i).Value = Range(col1 & i).Value
_
& " " & Range(col2 & i).Value
Next
'Se vogliamo concatenare diverse volte
'o per non tenire la colonna B
Range(col2 & ":" & col2).ClearContents
End Sub
Numero esempio :
59
Titolo : Sopprimere_una_riga_su_due
Autore : MacGimpsey, mpep
Commento : Permette di sopprimere una riga su x secondo vostra
voglia.
Public Sub DeleteEachNth()
JE MacGimpsey, mpep
Dim deleteRange As Range
Dim interval As Long
Dim response As Variant
Dim i As Long
Dim iBoxMsg As String
iBoxMsg = "Numero di riga a sopprimere tra le
righe a tenire e" & _
vbNewLine & _
"(per es., 3 : tienne le righe 1, 5, 9, 13,
..." &
vbNewLine & _
"7 : tienne le righe 1, 9, 17, 25,...)"
response = InputBox(iBoxMsg, "Intervalle", 3)
If IsNumeric(response) Then
interval = CLng(response)
Set deleteRange = Cells(2, 1).Resize(interval,
1)
For i = (2 + (interval + 1)) To _
ActiveSheet.Cells.SpecialCells(xlCellTypeLastCell).Row _
Step (interval + 1)
Set deleteRange = Union(deleteRange, Cells(i,
1). _
Resize(interval, 1))
Next i
deleteRange.EntireRow.Delete
End If
End Sub
Numero esempio :
60
Titolo : Cambiare_riferimenti_dei_riferimenti_fissi
Autore : Marc R Bertrand, mpfe
Commento : convertire i riferimenti delle celle nelle formule
che hanno dei riferimenti assoluti
Sub Absolutely()
Marc R Bertrand, mpfe
Dim c As Range
Dim LaFormule As String
For Each c In Selection
LaFormule = c.Formula
c.Value = Application.ConvertFormula _
(Formula:=LaFormule, fromReferenceStyle:=xlA1,
_
toReferenceStyle:=xlA1,
ToAbsolute:=xlAbsolute)
Next c
End Sub
Numero esempio :
61
Titolo : Copiare_una_formula
Autore : Tim Barlow, mpep
Commento : Permette di copiare una formula senza cambiare il
riferimento.
Sub CopyFormula()
Tim Barlow, mpep
Dim stgFormula As String
'Per prendere la formula
stgFormula =
Sheets("Sheet1").Range("B14").Formula
'Per digitarla
Sheets("Sheet2").Range("B1").Formula =
stgFormula
'Per copiare la formula di un posto a un altro
Sheets("Sheet2").Range("B2").Formula = _
Sheets("Sheet1").Range("B14").Formula
'Per salvarla in un file testo
Open "test.txt" For Output As 1
Write #1, stgFormula
Write #1, Sheets("Sheet2").Range("B1").Formula
Close 1
End Sub
Numero esempio :
62
Titolo : Copiare_le_formule_senza_cambiare_i_riferimenti
Autore : L Longre, mpfe
Commento : Permette di copiare le formule della zona scelta senza
che le riferimenti siano cambiati. Le macro si chiamano copia e
incolla. Potete assegnare due icone sul menu per potere usarle con
piu di facilità.
'
=========================================
Dim Zona As Range
Sub Copia()
On Error GoTo Erreur
If Not TypeOf Selection Is Range Then Exit Sub
Selection.Copy
Set Zona = Selection
Exit Sub
Erreur:
MsgBox Err.Description, vbCritical
End Sub
Sub incolla()
Dim NbLignes As Long, NbCols As Integer
On Error GoTo Erreur
If Not TypeOf Selection Is Range Or Zona Is
Nothing Then Exit Sub
NbLignes = Zona.Rows.Count
NbCols = Zona.Columns.Count
Zona.Copy
With Range(Selection.Address)
If .Areas.Count > 1 Then _
MsgBox "Impossibile di incollare su una zona
discontinuata.", _
vbCritical: Exit Sub
If .Count > 1 Then
If .Rows.Count <> NbLignes Or .Columns.Count
<> NbCols Then _
MsgBox "La taglia della zona selezionata non
corresponde " _
& "con quella a copiare.", vbCritical: Exit
Sub
Set Dest = .Cells
Else: Set Dest = .Resize(NbLignes, NbCols)
End If
End With
Application.ScreenUpdating = False
Dest.FormulaLocal = Zona.FormulaLocal
Dest.Select
Exit Sub
Erreur:
MsgBox Err.Description, vbCritical
End Sub
' =========================================
Numero esempio :
63
Titolo : Copiare_solo_le_formule
Autore : Laurent Longre
Commento : Permette di capire le formule di un foglio verso un'altro
senza usara Incolla speciale. Dovete usare la macro "copiaformule"
per copiare il foglio, e la macro "Incollaformule" per incollare nel
nuovo foglio.
Laurent Longre
Dim Plage As Range
Sub CopiaFormule()
Set Plage = Selection
Plage.Copy
End Sub
Sub InCollaFormule()
Dim I As Long, J As Integer
Dim Lignes As Long, Cols As Integer
Dim Dest As Range
Set Dest = Selection
Lignes = Plage.Rows.Count
Cols = Plage.Columns.Count
If Dest.Count = 1 Then
Set Dest = Dest.Resize(Lignes, Cols)
ElseIf Dest.Rows.Count <> Lignes Or
Dest.Columns.Count <> Cols Then
MsgBox "La taglia della spiaggia non
corresponde"
Exit Sub
End If
Application.ScreenUpdating = False
For I = 1 To Lignes
For J = 1 To Cols
If Plage(I, J).HasFormula Then Plage(I,
J).Copy Dest(I, J)
Next J
Next I
Dest.Select
Plage.Copy
End Sub
'altra soluzione
'per coppiare nello stesso posto di foglio1
verso foglio2
'solo le formule del foglio1
Sub PourGeo()
'Catherine Copigny, mpfe
Feuil1.UsedRange.SpecialCells(xlCellTypeFormulas, 23).Select
For Each zaza In Selection
Feuil2.Range(zaza.Address).FormulaLocal =
zaza.FormulaLocal
Next
End Sub
Numero esempio :
64
Titolo : Trovare_il_colore_di_formatazzione_condizionale
Autore : Laurent Longre, MPFE
Commento : Permette di conoscere il colore della cella in cui avete
applicato una formatazzione condizionale.
Sub
ElleEstBelleMaMEFC()
Dim FC As FormatCondition, F1, F2
Dim C As Range
Set C = Cells.Find(Empty)
Application.ScreenUpdating = False
For Each FC In ActiveCell.FormatConditions
C.FormulaLocal = FC.Formula1: F1 = C
If FC.Type = xlCellValue Then
Select Case FC.Operator
Case xlBetween, xlNotBetween:
C.FormulaLocal = FC.Formula2: F2 = C
If FC.Operator = xlBetween Then If ActiveCell
>= F1 _
And ActiveCell <= F2 Then Ex it For
If ActiveCell < F1 _
Or ActiveCell > F2 Then Exit F or
Case xlEqual: If ActiveCell = F1 Then Exit For
Case xlGreater: If ActiveCell > F1 Then Exit
For
Case xlGreaterEqual: If ActiveCell >= F1 Then
Ex it For
Case xlLess: If ActiveCell < F1 Then Exit For
Case xlLessEqual: If ActiveCell <= F1 Then
Exit Fo r
Case xlNotEqual: If ActiveCell <> F1 Then Exit
F or
End Select
Else
If F1 Then Exit For
End If
Next FC
If Not FC Is Nothing Then MsgBox
FC.Interior.ColorInde x _
Else MsgBox ActiveCell.Interior.ColorInd ex
C.Clear
End Sub
Numero esempio :
65
Titolo : Inserire_caselle_a_puntare
Autore : Benoit Marchand, mpfe
Commento : Permette di inserire delle caselle a puntare (checkbox)
nelle celle scelte.
Sub
Inserirecaselleapuntare()
Dim Reponse As Variant, n&
Reponse = InputBox("Quante celle volete" & _
" riempire nella colonna " _
& ActiveCell.Column & Ch r(13) _
& "inizio dell' inserzione : " & Act
iveCell.Row, _
"Inserzione delle caselle a puntare", 10)
If Not IsNumeric(Reponse) Then Exit Sub
For n = 1 To Reponse
ActiveSheet.CheckBoxes.Add(0, 0, 60, 12.75).Se
lect
Selection.Characters.Text = "caselle a puntare
" & ActiveCell.Row
With Selection
.Value = xlOff
.LinkedCell = ActiveCell.Address
.Display3DShading = True
End With
Call TailleObjetDansSelection
ActiveCell.NumberFormatLocal = ";;;"
ActiveCell.Offset(1, 0).Select
Next
End Sub '_______________________________
__________ _
Private Sub TailleObjetDansSelection()
Dim NomObjet As Variant, LongueurObjet A s
Single
Dim HauteurObjet As Single
Dim Col As Object, Lig As Object
Dim NuLig As Integer, NuCol As Integer
Dim Cell, StartRow As Single
Dim ColonneDepart As Single, x As Intege r
On Error GoTo GestErreur
NomObjet = Selection.Name
ActiveCell.Activate
Cell =ActiveCell.Address() ' Memorizza la
prima cella
NuCol = Range(Cells(1, 1), Cell).Columns
.Count
NuLig = Range(Cells(1, 1), Cell).Rows.Count
' Ricerca della taglia del oggetto
For Each Col In Selection.Columns
LongueurObjet = LongueurObjet + Col. Width
Next
' Ricerca dell'altezza del oggetto
For Each Lig In Selection.Rows
HauteurObjet = HauteurObjet + Lig.Height
Next
' Ricerca della posizione verticale
For x = 1 To NuLig - 1
StartRow = StartRow + Rows(x).Height
Next x
' Ricerca della posizione orrizontale
For x = 1 To NuCol - 1
ColonneDepart = ColonneDepart + Colu
mns(x).Wid th
Next x
' Formatazzione dell' oggetto nel foglio
ActiveSheet.DrawingObjects(NomObjet).Sel ect
With Selection
.Left = ColonneDepart
.Top = StartRow
.Width = LongueurObjet
.Height = HauteurObjet
End With
GestErreur:
End Sub
Numero esempio :
66
Titolo : Ultima_cella
Autore : mpfe (doc J@C)
Commento : Macro e funzione per conoscere l'ultima cella piena.
Sub test()
MsgBox DerCell.Address
' MsgBox DERCELLCURRENT(ActiveCell).Address
End Sub
Sub GetRealLastCell()
mpfe (doc J@C)
Dim RealLastRow As Long
Dim RealLastColumn As Long
Range("A1").Select
On Error Resume Next
RealLastRow = _
Cells.Find("*", [A1], , , xlByRows,
xlPrevious).Row
RealLastColumn = _
Cells.Find("*", [A1], , , xlByColumns,
xlPrevious).Column
Cells(RealLastRow, RealLastColumn).Select
End Sub
Function DerCell() As Range
Dim derLi, derCol
On Error GoTo fin
derLi = Cells.Find("*", [A1], , , 1, 2).Row
derCol = Cells.Find("*", [A1], , , 2,
2).Column
Set DerCell = Cells(derLi, derCol)
Exit Function
fin:
Set DerCell = Cells(1, 1)
End Function
Function DERCELLCURRENT(cell As Range) As
Range
Dim derLi, derCol
derLi = cell.CurrentRegion.Row + _
cell.CurrentRegion.Rows.Count - 1
derCol = cell.CurrentRegion.Column + _
cell.CurrentRegion.Columns.Count - 1
Set DERCELLCURRENT = Cells(derLi, derCol)
End Function
'- per trovare l'ultima cella piena :
'LL, mpfe
Function DerLi1()
DerLi1 = Cells.Find("*", [A1],
SearchDirection:=xlPrevious).Row
End Function
- per trovare l'ultima cella riempita con un
valore e non una formula :
Function DerLi2()
With
Cells.SpecialCells(xlCellTypeConstants).Areas
DerLi2 =
.Item(.Count)(.Item(.Count).Count).Row
End With
End Function
Numero esempio :
67
Titolo : ultima_riga
Autore : Robert Rosenberg, mpep
Commento : Sono tre funzioni diverse che permettono di conoscere
l'ultima riga piena di un foglio o di una colonna.
Function
lLastRow(wks As Worksheet, lCol As Long) As Long
Robert Rosenberg, mpep
'foglio e colonna a scelta
lLastRow = wks.Cells(65536, lCol).End( xlU
p).Row
End Function
Function DerLi()
'David Mac Ritchie, mpep
'foglio attivo
Dim LastRow As Long
ActiveSheet.UsedRange
LastRow = Cells.SpecialCells(xlLastCel l). Row
DerLi = LastRow
End Function
Function LastRow()
'Tom Ogilvy, mpep
'foglio attivo, colonna A
LastRow = Cells(Cells.Rows.Count, "A") .En
d(xlUp).Row
End Function
Numero esempio :
68
Titolo : Cancellare_righe_vuote
Autore : Bart Smissaert (from J. Walkenbach ?), mpep
Commento : Permette di cambiare le righe vuote di una zona scelta.
Se volete cancellare le righe vuote di un intero foglio, potete
usare il filtro automatico !
Sub
DeleteEmptyRows()
Application.ScreenUpdating = False
Dim LR As Long
Dim n As Long
LR = Selection.Rows.Count
With Selection
For n = LR To 1 Step -1
If Application.CountA(.Rows(n)) = 0 Then _
.Cells(n, 1).EntireRow.Delete
Next n
End With
Application.ScreenUpdating = True
End Sub
Numero esempio :
69
Titolo : Prendere_i_dati_senza_doppi
Autore : J. Walkenbach
Commento : Permette di prendere i dati di una zona e di coppiarli
senza i dati doppi.
Function
IncollaValoriUnici(Plage) As Collection
J. Walkenbach
'Ritorna in una collezione i valori unici
'di una zona di celle
Dim AllCells As Range, cell As Range
Dim NoDupes As New Collection
Dim i As Integer, j As Integer
Dim Swap1, Swap2, Item
Set AllCells = Plage
On Error Resume Next
For Each cell In AllCells
NoDupes.Add cell.Value, CStr(cell.Value)
Next cell
On Error GoTo 0
' Sort the collection
For i = 1 To NoDupes.Count - 1
For j = i + 1 To NoDupes.Count
If NoDupes(i) > NoDupes(j) Then
Swap1 = NoDupes(i)
Swap2 = NoDupes(j)
NoDupes.Add Swap1, before:=j
NoDupes.Add Swap2, before:=i
NoDupes.Remove i + 1
NoDupes.Remove j + 1
End If
Next j
Next i
Set CollTrieeSansDoublons = NoDupes
End Function
Numero esempio :
70
Titolo : Creare_da_una_zona_un_elenco_di_convalida
Autore : Iznogood, mpfe
Commento : Per creare una convalida con un elenco a partire di una
zona senza metterci i doppi.
Sub MajValid()
Iznogood, mpfe
Dim t() As Variant
Dim r As Range
Dim i As Long
Dim flag As Boolean
Dim formule As String
ReDim t(0)
For Each r In Range("A1").CurrentRegion
flag = True
For i = 1 To UBound(t)
If t(i) = r Then flag = False
Next i
If flag Then
ReDim Preserve t(UBound(t) + 1)
t(UBound(t)) = r
End If
Next r
For i = 1 To UBound(t)
formule = formule & t(i) & ","
Next i
With Range("C1").Validation
.Delete
.Add Type:=xlValidateList, Formula1:=formule
End With
End Sub
Numero esempio :
71
Titolo : Creare_una_tabella_con_i_nomi_dei_fogli
Autore : Eric Renaud, mpfe
Commento : Conta tutti i fogli, e crea una tabella con tutti i nomi
dei fogli presenti nella cartella attiva.
Sub ListareFogli()
' Eric Renaud, mpfe
' Guarda il numero di fogli
Dim Arr() As String
Dim i As Integer, NbSheets As Integer
NbSheets = Worksheets.Count
ReDim Arr(1 To NbSheets)
'crea la tabella Arr con i nomi dei fogli
For i = 1 To NbSheets
Arr(i) = Worksheets(i).Name
Next i
Sheets.Add.Name = "ListeFeuilles"
'scrive l'elenco in una colonna
Range("A1:A" & NbSheets) =
Application.Transpose(Arr)
'scrive l'elenco in una riga
Range(Cells(1, 1), Cells(1, NbSheets)) = Arr
Range("A1").Select
End Sub
Numero esempio :
72
Titolo : Creare_una_tabella_con_le_formule_del_foglio_attivo
Autore : Torsten Harden
Commento : Volete sarer tutto sulle formule di un foglio : questa
macro permette di sapere le informazioni seguenti :
- indirizzo della cella della formula
- formula nella langua del utente
- formula nella langua di Excel (inglese)
- volori del risultato
- formato della lingua dell'utente
- formato della lingua di Excel
- pubblica valori
Option Explicit
Const MSGFeuille = _
"Il programma non puo funzionare se non c'e un
foglio attivo."
Const MSGFormule = "Nel foglio attivo, non ci
sono delle formule."
Sub
CreerListeFormules() ''per Torsten Harden
'Con un'idea di John Walkenbach
'traduzione Remi
Dim PlageFormules As Range, Cellule As Range
Dim FeuilleFormules As Worksheet, Ligne As
Integer, Reponse
'lasciare la sub se il foglio attivo non e un
foglio Excel
If TypeName(ActiveSheet) <> "Worksheet" Then
Reponse = MsgBox(MSGFeuille, vbCritical)
Exit Sub
End If
On Error Resume Next
'Crea una zona con tutte le formule
Set PlageFormules =
Range("A1").SpecialCells(xlFormulas, 23)
'Esce se non ci sono delle formule
If PlageFormules Is Nothing Then
Reponse = MsgBox(MSGFormule, vbExclamation)
Exit Sub
End If
Application.ScreenUpdating = False
'Aggiunge un foglio di calcolo
Set FeuilleFormules =
ActiveWorkbook.Worksheets.Add
FeuilleFormules.Name = "Formule nel " &
PlageFormules.Parent.Name
'aggiunge i titoli di colonna
With FeuilleFormules
.Range("A1") = "Indirizzo"
.Range("B1") = "Formula"
.Range("C1").Value = "Formula in inglese"
.Range("D1") = "risultato"
.Range("E1") = "formato"
.Range("F1").Value = "Formato ""originale"""
.Range("G1") = "Valore visibile"
.Range("A1:G1").Font.Bold = True
.Columns("E:F").NumberFormat = "@" 'Formato
del testo per le colonne "Format"
End With
'per ogni formula
Ligne = 2
For Each Cellule In PlageFormules
Application.StatusBar = Format((Ligne - 1) /
PlageFormules.Count, "0%")
With FeuilleFormules
.Cells(Ligne, 1) = Cellule.Address(0, 0)
.Cells(Ligne, 2) = " " & Cellule.FormulaLocal
.Cells(Ligne, 3).Value = " " & Cellule.Formula
.Cells(Ligne, 4) = Cellule.Value
.Cells(Ligne, 5) = Cellule.NumberFormatLocal
.Cells(Ligne, 6).Value = Cellule.NumberFormat
.Cells(Ligne, 7) = Cellule.Value
.Cells(Ligne, 7).NumberFormat =
Cellule.NumberFormat
Ligne = Ligne + 1
End With
Next Cellule
'adatta la larghezza delle colonne
FeuilleFormules.Columns("A:G").AutoFit
Application.StatusBar = False
End Sub
Numero esempio :
73
Titolo : Sopprimere_formati_Personalizzati_Non_Usati
Autore : L Longre, mpfe
Commento : I formati personalizzati, fano crescere il volumo del
file, così, è utile di pulirlo qualche volta. - Questa macro quindi
sopprime tutti i formati personnalizzati non usati nella cartella
- La macro sopprime anche i formatti non usati e anche le celle che
sono attaccati a delle celle vuote
Dovete aggiungere al progetto il riferimento '"Microsoft Forms 2.0
Object Library".
'=======================
Sub
SopprFormatNonUsati()
SupprFormats True
End Sub
Sub SopprFormatCelleVuote()
SupprFormats False
End Sub
Private Sub SupprFormats(Min As Boolean)
Dim Form As String, Prev As String, F As Str
in g
Dim I As Integer, J As Integer
Dim dObj As New DataObject, C As New Collect
io n
Dim Wksht As Worksheet, Cell As Range, Shts As
Sheet s
Application.EnableCancelKey = xlDisabled
Application.StatusBar = "Lista i formati... "
Do
J = (J + 1) Mod 5
If J = 0 Then I = I + 1
Application.SendKeys "{TAB}{END}{TAB 2}{HO ME
}" & I If(I, "{PGDN " _
& I & "}", "") & IIf(J, "{DOWN " & J & " }" ,
"") & "+{TAB}^c{ESC}"
Application.Dialogs(xlDialogFormatNumber). Sh
ow
dObj.GetFromClipboard
Form = dObj.GetText(1)
If Form = Prev Then Exit Do
C.Add Form, Form
Prev = Form
Loop
Application.StatusBar = "Ricerca dei formati
in corso..."
Set Shts = ActiveWindow.SelectedSheets
On Error Resume Next
For Each Wksht In Worksheets
Wksht.Select
For Each Cell In Wksht.UsedRange
If Not IsEmpty(Cell) Or Min Then
F = C.Item(Cell.NumberFormatLocal)
If F <> "" Then
C.Remove Cell.NumberFormatLocal
F = ""
End If
End If
Next Cell
Next Wksht
Application.ScreenUpdating = False
Err.Clear
Application.StatusBar = False
J = 0
With ActiveWorkbook
Workbooks.Add
For I = 1 To C.Count
Range("A1").NumberFormatLocal = C(I)
.DeleteNumberFormat ActiveCell.NumberFor ma t
If Err = 0 Then J = J + 1 Else Err.Clear
Next I
MsgBox J & " I formati non usati sono
sopprimati. ", vbInformation
End With
ActiveWorkbook.Close False
Shts.Select
End Sub
'=============================================
== ====
Numero
esempio : 74
Titolo : Trova-Sostutuici_un testo_troppo_longo
Autore : Jim Rech, mpep
Commento :
Attribute VB_Name =
"FormulaTroppoLonga"
Trova/Sostutuici un testo
'quando il testo Þ troppo longo
Sub RunReplace()
Jim Rech, mpep
Dim strOldStr As String, strNewStr As String
strOldStr = InputBox("Trova e")
If strOldStr <> "" Then
strNewStr = InputBox("Sostutuici :")
If strNewStr <> "" Then
DoReplace Selection, strOldStr, strNewStr
End If
End If
End Sub
Sub DoReplace(rngReplace As Range, strWhat As
String, strReplace As String)
Dim rngCell As Range
For Each rngCell In rngReplace.Cells
rngCell.Value = Replace(rngCell.Value,
strWhat, strReplace)
Next
End Sub
Numero esempio :
75
Titolo : Unire_due_colonne
Autore : Michel Charlier, mpfe
Commento : Permette di unire due colonne.
Questa macro si usa selezionando la zona a destra delle due colonne
che volete unire. Per esemio, per unire la zona A1:B100, dovete
selezionare la zona C1:C100 ed avviare la macro.
Sub UnioneColonne()
Application.ScreenUpdating = False
Selection.FormulaR1C1 = "=RC[-2]& "" ""
&RC[-1]"
Selection.Value = (Selection.Value)
Columns("A:B").Select
Selection.Delete Shift:=xlToLeft
Range("A1").Select
End Sub
Numero esempio :
76
Titolo : Contare_celle_visibile
Autore :
Commento : Aggiorna una colonna da 1 a "n" righe, che le righe siano
visibili o non. Aggiornamento della zona automatico con un filtro.
usare Ctrl + F9 per aggiornare.
Function
IncSeVisible(cellPrec)
Application.Volatile
If cellPrec.EntireRow.Hidden = True Then
IncSiVisible = cellPrec.Value
Else
IncSeVisible = cellPrec.Value + 1
End If
End Function
Numero esempio :
77
Titolo : Informa_se_le_Celle_sono_unite
Autore :
Commento : Permette di sapere se le celle sono unite o non.
Sub InformazioneUnione()
InfoFusion Range("e1")
MsgBox IsMerged(Range("e1:e2"))
End Sub
Sub InfoFusion(cell As Range)
Dim Msg$
If cell.MergeCells Then
With cell.MergeArea
Msg = "Zona unita : " & .Address(0, 0) & v bLf
Msg = Msg & "Numero di celle : " & .Count &
vbLf
Msg = Msg & "valore della zona : " & .R ange(
"A 1").Value & vbLf
'se Excel 2000 o +
Msg = Msg & "Prima colonna della zona : " & Sp
lit(.Address, "$")(1)
'altrimenti
' Msg = Msg & "Seconda colonna della zona a :
" & .Column
End With
Else
Msg = " La cella " & cell.Address(0, 0) & _
" non fa parte di una zona unita"
End If
MsgBox Msg
End Sub 'fs
'o, altrimenti...
Function
IsMerged(cell As Range) As Boolean
On Error GoTo Fin
IsMerged = cell.MergeCells
Fin:
End Function
Numero
esempio : 78
Titolo : Analizzare_la_composizione_di_una_zona
Autore : J Walkenbach, mpep
Commento : Analizza la composizione di una zona di celle
Sub
AboutRangeSelection()
'J Walkenbach, mpep
Dim NumCols As Integer
Dim NumRows As Long
Dim NumBlocks As Integer
Dim NumCells As Long
Dim NumAreas As Integer
Dim SelType As String
Dim FirstAreaType As String
Dim CurrentType As String
Dim WhatSelected As String
Dim UnionRange As Range
Dim Area As Range
Dim Msg As String
'Esce se non ci sono delle celle selezionate
If TypeName(Selection) <> "Range" Then Exit
Sub
' Comincia a contare
NumCols = 0
NumRows = 0
NumBlocks = 0
NumCells = 0
' Determina il numero di celle
NumAreas = Selection.Areas.Count
If NumAreas = 1 Then
SelType = "Selezione semplice"
Else
SelType = "Selezione multipla"
End If
FirstAreaType = AreaType(Selection.Areas(1))
WhatSelected = FirstAreaType
' Fa l'unione di tutte le selezioni
Set UnionRange = Selection.Areas(1)
For Each Area In Selection.Areas
CurrentType = AreaType(Area)
' Conta il numero di celle prima l'unione
If CurrentType = "Block" Then NumBlocks =
NumBlocks + 1
Set UnionRange = Union(UnionRange, Area)
' cambia il nome se l'unione Þ "mixed"
If CurrentType <> FirstAreaType Then
WhatSelected = "Mixed"
Next Area
' Guarda ogni celle nell'unione
For Each Area In UnionRange.Areas
Select Case AreaType(Area)
Case "Row"
NumRows = NumRows + Area.Rows.Count
Case "Column"
NumCols = NumCols + Area.Columns.Count
Case "Worksheet"
NumCols = NumCols + Area.Columns.Count
NumRows = NumRows + Area.Rows.Count
Case "Block"
' zona già contato prima
End Select
Next Area
' Count number of non-overlapping cells
NumCells = UnionRange.Count
Msg = "Selezion del tipo :" & vbTab &
WhatSelected & vbCrLf
Msg = Msg & "No. of Areas:" & vbTab & NumAreas
& vbCrLf
Msg = Msg & "Full Columns: " & vbTab & NumCols
& vbCrLf
Msg = Msg & "Full Rows: " & vbTab & NumRows &
vbCrLf
Msg = Msg & "Cell Blocks:" & vbTab & NumBlocks
& vbCrLf
Msg = Msg & "Total Cells: " & vbTab &
Format(NumCells, "#,###")
MsgBox Msg, vbInformation, SelType
End Sub
Private Function AreaType(RangeArea As Range)
As String
' Da il tipo di zona
Select Case True
Case RangeArea.Cells.Count = 1
AreaType = "Cell"
Case RangeArea.Count = Cells.Count
AreaType = "Worksheet"
Case RangeArea.Rows.Count = Cells.Rows.Count
AreaType = "Column"
Case RangeArea.Columns.Count =
Cells.Columns.Count
AreaType = "Row"
Case Else
AreaType = "Block"
End Select
End Function
Numero esempio :
79
Titolo : Inserire_riga_con_formule
Autore : Mark Hill
Commento : Permette di aggiungere una o diverse righe, copiando le
formule della riga esistante.
'
Documented:
http://www.geocities.com/davemcritchie/excel/insrtrow.htm
Sub
InsertRowsAndFillFormulas(Optional vRows As Long)
' selezionate le righe sulla riga attiva --
rev. 2000-09-02 David McRitchie
ActiveCell.EntireRow.Select 'Non avete bisogno
di selezionare la riga intera
If vRows <> 1 Then
vRows = Application.InputBox(prompt:= _
"Quante righe volete aggiungere e",
Title:="Add Rows", _
Default:=1, Type:=1) 'tipo 1 Þ numero
If vRows = False Then Exit Sub
End If
'se volete aggiungere solodelle celle invece
della riga
'allora sopprimete ".EntireRow" nelle righe
seguente
'rev. 2001-01-17 Gary L. Brown, programming,
Grouped sheets
Dim sht As Worksheet, shts() As String, i As
Integer
ReDim shts(1 To
Worksheets.Application.ActiveWorkbook. _
Windows(1).SelectedSheets.Count)
i = 0
For Each sht In _
Application.ActiveWorkbook.Windows(1).SelectedSheets
Sheets(sht.Name).Select
i = i + 1
shts(i) = sht.Name
Selection.Resize(rowsize:=2).Rows(2).EntireRow. _
Resize(rowsize:=vRows).Insert Shift:=xlDown
Selection.AutoFill Selection.Resize( _
rowsize:=vRows + 1), xlFillDefault
On Error Resume Next 'to handle no constants
in range -- John McKee 2000/02/01
' to remove the non-formulas -- 1998/03/11
Bill Manville
Selection.Offset(1).Resize(vRows).EntireRow. _
SpecialCells(xlConstants).ClearContents
Next sht
Worksheets(shts).Select
End Sub
Sub InsertBeforeTotalinColumnA()
' Columns("A:A").Find(What:="total",
After:=Range("A2"), LookIn:=xlValues, _
' LookAt:=xlPart, SearchOrder:=xlByColumns,
SearchDirection:=xlNext, _
' MatchCase:=False).Offset(-1, 0).Activate
Call InsertRowsAndFillFormulas(1) 'see my
insrtrow.htm page
End Sub
Numero esempio :
80
Titolo : Inserire_riga_sotto
Autore : fs
Commento : Permette di inserire una riga intera sotto la cella
attiva
Sub InserireSotto()
ActiveCell(2).Resize(15).EntireRow.Insert
End Sub
Numero esempio :
81
Titolo : Inserire_riga_sotto_con_formule
Autore :
Commento : Permette di inserire una riga sotto la cella attiva, però
copia anche le formule della riga della cella attiva.
Sub
InserireSottoConFormule()
fs
Application.ScreenUpdating = False
ActiveCell(2).Resize(1).EntireRow.Insert
ActiveCell(1).EntireRow.Copy
ActiveCell(2).Resize(1).EntireRow
On Error Resume Next 'Nel caso dove non ci
sono "constantes"
ActiveCell(2).Resize(1).EntireRow. _
SpecialCells(xlConstants).ClearContents
End Sub
Numero esempio :
82
Titolo : Inserire_righe_sopra_o_sotto
Autore : Jacky @*10-1
Commento : Permette di inserire una riga sotto o sopra la cella
attiva (secondo la macro usata) e di copiare le formule.
Dim ZtNumLig As Integer
Dim ZtDerCol As Integer
ActiveCell.Range("A2").EntireRow.Insert
ZtNumLig = ActiveCell.Row
ZtDerCol = Cells(ActiveCell.Row, 1).End(xlTo
Right).Column
Range(Cells(ZtNumLig, 1), Cells(ZtNumLig, Zt
DerCol)).Copy _
Range(Cells(ZtNumLig + 1, 1), Cells(ZtNu mLig
+ 1, ZtDerCol))
Application.ScreenUpdating = False
For i = 1 To ZtDerCol
If Not Cells(ZtNumLig + 1, i).HasFormula Then
Cells(ZtNumLig + 1, i).ClearContents
End If
Next i
ActiveCell.Range("A2").Select
End Sub
Sub RigaSoppra()
' In serire una riga sopra la cella attiva
' e copia/Incolla le formule
Dim ZtNumLig As Integer
Dim ZtDerCol As Integer
ActiveCell.EntireRow.Insert
ActiveCell.Range("A2").Select
ZtNumLig = ActiveCell.Row
ZtDerCol = Cells(ActiveCell.Row, 1).End(xlTo
Right).Column
Range(Cells(ZtNumLig, 1), Cells(ZtNumLig, Zt
DerCol)).Copy _
Range(Cells(ZtNumLig - 1, 1), Cells(ZtNu mLig
- 1, ZtDerCol))
Application.ScreenUpdating = False
For i = 1 To ZtDerCol
If Not Cells(ZtNumLig - 1, i).HasFormula Then
Cells(ZtNumLig - 1, i).ClearContents
End If
Next i
ActiveCell.Offset(-1, 0).Select
End Sub
Sub NouvelleLigne()
Ma cro de "Jacky @*10-1"
' Inserire una riga sopra la cella attiva
' e copia/Incolla le formule della riga sopra
la nuova riga
' Non funziona sulla riga 1
Dim ZtNumLig As Integer
Dim ZtDerCol As Integer
ActiveCell.EntireRow.Insert
ZtNumLig = ActiveCell.Row
Range("$A$" & ZtNumLig - 1).Select
ZtDerCol = Selection.SpecialCells(xlCellTyp
eLastCell).Column
Rows(ZtNumLig - 1).Select
Selection.Copy
Rows(ZtNumLig).Select
ActiveSheet.Paste
Application.CutCopyMode = False
Do While ActiveCell.Column <= ZtDerCol
If Left(ActiveCell.FormulaLocal, 1) < " ="
Then
ActiveCell = ""
End If
ActiveCell.Offset(0, 1).Select
Loop
Range("$A$" & ZtNumLig).Select
End Sub
Numero esempio :
83
Titolo : Vietare_di_digitare_nelle_celle_scelte
Autore : Laurent MortÚzai, mpfe
Commento : Proibire l'accesso a diverse celle senza usare la
protezione del foglio. Questa macro puo essere chiamata con un
evento change del foglio o della cartella.
Sub
PasTouche(LaCellule As Range, PlageAutorisÚe As Range)
If Intersect(LaCellule, PlageAutorisÚe) Is
Nothing Then
MsgBox "Non toccare !"
Application.EnableEvents = False
Application.Undo
Application.EnableEvents = True
End If
End Sub
'Private Sub Workbook_SheetChange(ByVal Sh As
Object, ByVal Target As Range)
' PasTouche Target, Range("A1:A10")
'End Sub
Numero esempio :
84
Titolo : Invertire_due_Colonne
Autore : fs
Commento : Permette con un semplice clic di invertire due colonne.
Sub ColReverse()
fs
Dim LCol$, LRow&, i&, ValCol
LCol = InputBox("Da quale colonna volete
invertire e", , "A ")
If LCol = "" Then Exit Sub
LRow = Range(LCol & Rows.Count).End(xlUp).Row
ValCol = Range(LCol & "1:" & LCol &
LRow).Value
LCol = InputBox("Nel quale colonna volete i
risultati e" , , "B")
If LCol = "" Then Exit Sub
Application.ScreenUpdating = False
For i = UBound(ValCol) To LBound(ValCol) Step
-1
Range(LCol & UBound(ValCol) - i + 1).Value =
ValCol(i, 1)
Next i
End Sub
Numero esempio :
85
Titolo : Trovare_l_indirizzo_dell'ultima_cella
Autore : Atticus, mpep
Commento : Trovare l'indirizzo dell'ultima cella
Sub ultimaCella()
MsgBox LastCell(Sheets(1)).Address
End Sub
Function LastCell(wWorksheet As Worksheet ) As
Range
Atticus, mpep
Err.Clear
On Error GoTo ErrTrap
Dim dLastRow As Double
Dim dLastCol As Double
With wWorksheet
' Trova l'ultima riga
dLastRow = .Cells.Find("*", , , , xlByRows,
xlPrevious).Row
' Trova l'ultima colonna
dLastCol = .Cells.Find("*", , , , xlByColumns,
xlPrevious).Column
Set LastCell = .Cells(dLastRow, dLastCol)
End With ' wWorkSheet
ExitDoor:
Exit Function
ErrTrap:
Set LastCell = wWorksheet.Cells(1 , 1)
Resume ExitDoor
End Function
Numero esempio :
86
Titolo : Convertire_in_lettere_il_numero_di_una_colonna
Autore : Dana DeLouis
Commento : Permette di cambiare il numero della colonna con la
lettera della colonna.
Function
Number2Letter(N As Long) As String
// Dana DeLouis
If N > 0 And N < 257 Then
Number2Letter = Split(Cells(N).Address, " $")
-1
Else
Number2Letter = Error(9) '> Subscript out of
range
End If
End Function
Sub test()
MsgBox Number2Letter(ActiveCell.Column)
MsgBox Number2Letter(256)
End Sub
Numero esempio :
87
Titolo : cambiare_i_punti_in_centimetri_delle_misuri
Autore : Microsoft
Commento : Questo codice dato dalla Microsoft, cambia il numero di
pixel per la larghezza delle colonne o delle righe con la misura in
centimetro per facilitare l'impostazione della pagina.
Sub
RowHeightInCentimeters()
Dim cm As Integer
' Get the row height in centimeters.
cm = Application.InputBox("Digitate
l'altezza della riga in centimetri", _
"Row Height (cm)", Type:=1)
' Il pulsante "cancel" non Þ premeto
If cm Then
' Converte i punti in centimetri
Selection.RowHeight =
Application.CentimetersToPoints( cm)
End If
End Sub
Sub ColumnWidthInCentimeters()
Dim cm As Integer, points As Integer,
savewidth As Integer
Dim lowerwidth As Integer, upwidth As Integer,
curwidth As Integer
Dim Count As Integer
' Non vede il lavoro
Application.ScreenUpdating = False
' Chiede le colonne
cm = Application.InputBox("Digitate la
larghezza delle colonne", _
"Column Width (cm)", Type:=1)
' Il pulsante "cancel" Þ premeto esce
If cm = False Then Exit Sub
' Converte i punti in centimetri
points = Application.CentimetersToPoints(cm)
' salva con la nuova configurazione
savewidth = ActiveCell.ColumnWidth
' Configura la larghezza massima
ActiveCell.ColumnWidth = 255
' Se il numero digitato e superiore alla
larghezza massima
If points > ActiveCell.Width Then
' Mostra il messaggio d'errore
' e da la larghezza massima
MsgBox "la larghezza " & cm & " Þ troppo
larga." & Chr (10) & _
"La larghezza massima Þ " & _
Format(ActiveCell.Width / 28.3464566929134, _
"0.00"), vbOKOnly + vbExclamation, "Width
Error"
' Configura come prima
ActiveCell.ColumnWidth = savewidth
' Esce della procedura
Exit Sub
End If
' Configura la larghezza minima e massima
lowerwidth = 0
upwidth = 255
' Configura la media
ActiveCell.ColumnWidth = 127.5
curwidth = ActiveCell.ColumnWidth
' Configura un conto da 0
Count = 0
' Cambia la larghezza di tutte le colonne
selezionnate al minimo da 20
While (ActiveCell.Width <> points) And (Count
< 20)
' Se la larghezza Þ troppo piccola
If ActiveCell.Width < points Then
' Cancella la larghezza digitata
lowerwidth = curwidth
' configura con la larghezza media
Selection.ColumnWidth = (curwidth + upwidth) /
2
' Se la larghezza Þ troppo grande
Else
'
upwidth = curwidth
' Configura la larghezza media
' width.
Selection.ColumnWidth = (curwidth + lowerwidth) / 2
End If
' Configura la larghezza delle colonne
curwidth = ActiveCell.ColumnWidth
' Conta
Count = Count + 1
Wend
End Sub
Numero
esempio : 88
Titolo : Sapere_la_formula_usata_in_una_cella
Autore : Patrick Penet, Modeste GeeDee
Commento : Permette di conoscere la formula usata e non il valore di
una cella scelta
Function
LireFormule(RÚfÚrenceCellule As Range, _
Optional LangageLocal As Boolean) As String
If LangageLocal = True Then
If RÚfÚrenceCellule.HasArray Then
LireFormule = "{" & RÚfÚrenceCellule.Formula
Lo cal & "}"
Else
LireFormule = " " & RÚfÚrenceCellule.Formula
Lo cal
End If
Else
If RÚfÚrenceCellule.HasArray Then
LireFormule = "{" & RÚfÚrenceCellule.Formula &
"}"
Else
LireFormule = " " & RÚfÚrenceCellule.Formula
End If
End If
End Function
'Usa :
'=lireformule(A1;VRAI)
Numero esempio :
89
Titolo : Cercare_i_riferimenti_di_una_zona
Autore : Stephen Bullen
Commento : Permette di sapere tutti i riferimenti di una zona
scelta.
Sub
DisplayPrecedentLines()
Application.ScreenUpdating = False
Dim C As Range, S As Worksheet, i As Integer,
Tmp As String
Set S = ActiveSheet
Application.ScreenUpdating = False
For Each C In Selection.Cells
C.Select
Tmp = ""
Application.ExecuteExcel4Macro
("TRACER.DISPLAY(TRUE,TRUE)")
On Error Resume Next
For i = 1 To 200
ActiveCell.NavigateArrow
TowardPrecedent:=True, ArrowNumber:=1, linknumber:=i
If Err <> 0 Or _
ActiveCell.Parent.Name & ActiveCell.Address =
C.Parent.Name & C.Address _
Then Exit For
If Tmp <> "" Then Tmp = Tmp & ", "
If ActiveCell.Parent.Name <> C.Parent.Name
Then
Tmp = Tmp & ActiveCell.Parent.Name & "!" &
ActiveCell.Address
Else
Tmp = Tmp & ActiveCell.Address
End If
S.Activate
C.Select
Next i
If Tmp <> "" Then MsgBox "I riferimenti per "
& C.Address & " sono " & Tmp
Application.ExecuteExcel4Macro
("TRACER.DISPLAY(TRUE,FALSE)")
Next C
End Sub
Numero esempio :
90
Titolo : Cercare_i_referimenti_di_una_zona_2
Autore : Bill Manville et Paul S., mpep
Commento : Permette di sapere tutti i riferimenti di una zona di
celle.
Sub FindPrecedents()
Bill Manville et Paul S., mpep
'Cerca i referimenti di una zona di celle
' I riferimenti di le altre cartelle sono
valabile se le cartelle sono aperte
Dim rLast As Range, iLinkNum As Integer,
iArrowNum As Integer
Dim stMsg As String
Dim bNewArrow As Boolean
Application.ScreenUpdating = False
ActiveCell.ShowPrecedents
Set rLast = ActiveCell
iArrowNum = 1
iLinkNum = 1
bNewArrow = True
Do
Do
Application.Goto rLast
On Error Resume Next
ActiveCell.NavigateArrow TowardPrecedent:=Tr
ue, _
ArrowNumber:=iArrowNum, LinkNumber:= iLi nkNum
If Err.Number > 0 Then Exit Do
On Error GoTo 0
If rLast.Address(external:=True) = _
ActiveCell.Address(external:=True) Th en Exit
Do
bNewArrow = False
If rLast.Worksheet.Parent.Name = ActiveCell.
Wor ksheet.Parent.Name Then
If rLast.Worksheet.Name = ActiveCell.Paren t.N
ame Then
' local
stMsg = stMsg & vbNewLine & Selection.Ad dre
ss
Else
stMsg = stMsg & vbNewLine & "'" & _
Selection.Parent.Name & "'!" & Select
ion.Address
End If
Else
' external
stMsg = stMsg & vbNewLine & Selection.Address
(external:=True)
End If
iLinkNum = iLinkNum + 1 'prova un'altro
collegamento
Loop
If bNewArrow Then Exit Do
iLinkNum = 1
bNewArrow = True
iArrowNum = iArrowNum + 1 'try another arrow
Loop
rLast.Parent.ClearArrows
Application.Goto rLast
MsgBox "I Riferimenti sono : " & stMsg
Exit Sub
End Sub
Numero esempio :
91
Titolo : Esempi_su_celle_colorate
Autore : Eric Jeanne, mpfe
Commento : Permette di sapere gli indirizzi, il numero di celle e i
valori che usano il colore scelto.
Due altre macro
sui colori.
Sub
MemeCouleur(Couleur&)
Dim cell, plageCouleur As Range
Dim tabValeur() As Variant
Set plageCouleur = Nothing
For Each cell In ActiveSheet.UsedRange
If cell.Interior.Color = Couleur Then
If plageCouleur Is Nothing Then
Set plageCouleur = cell
Else
Set plageCouleur = Union(plageCoule ur, cell)
End If
ReDim Preserve tabValeur(plageCouleur.C ell
s.Count)
tabValeur(plageCouleur.Cells.Count - 1) = cell
End If
Next
If plageCouleur Is Nothing Then
MsgBox "nessuna cella del colore chiesto"
Else
For N = 1 To plageCouleur.Cells.Count
ch = ch & " " & tabValeur(N - 1)
Next
MsgBox plageCouleur.Address & " " & plageC oul
eur.Cells.Count & " cell."
MsgBox ch
End If
End Sub
'Da il colore blu alle celle non proteggate
Sub Celle_deproteggate_in_blu()
'mpfe, Eric Jeanne & JP AllardiÞres
For Each c In ActiveSheet.UsedRange
If Not c.Locked And c.Font.ColorIndex = xlC
olo rIndexAutomatic Then _
c.Font.ColorIndex = 5
Next
End Sub
'Impone una polizia nera
Sub Cellules_dÚvÚrrouillÚes_en_noir()
'mpfe, Eric Jeanne & JP AllardiÞres
For Each c In ActiveSheet.UsedRange
If Not c.Locked And c.Font.ColorIndex = 5 T
hen _
c.Font.ColorIndex = xlColorIndexAutomat ic
Next
End Sub
Numero esempio :
92
Titolo : Esempi_sulle_righe_e_le_colonne
Autore : L Longre, mpfe
Commento : Diverse macro con oggetto le righe e le colonne.
Attribute VB_Name =
"ManipsLignesEtColonnes"
'Paragona i valori tra due colonne
'tutti valori non presenti nella colonna A
sono aggiunti nella colonna A
Sub ParanogareColonne()
L Longre, mpfe
Dim cell As Range, Plage As Range, I As Long
Set Plage = Range("A1", [A1].End(xlDown))
I = Plage.Count
Application.ScreenUpdating = False
For Each cell In Range("B1", [B1].End(xlDown))
If Plage.Find(cell, Plage(1), xlValues,
xlWhole) Is Nothing Then
I = I + 1
Cells(I, 1) = cell
End If
Next cell
End Sub
'sopprimere una riga su due
'selezionate le righe e avviate la macro
'questo esempio sopprime una riga su due
comminciando per la prima
Sub Efface1sur2()
'Iznogood, mpfe
Dim r As Object
If MsgBox("Sopprimere una riga su due e",
vbYesNo) = vbYes Then
For Each r In Selection.Rows
r.EntireRow.Delete
Next r
End If
End Sub
'sopprimere le righe vuote di una selezione
Sub SopRigheVuote()
'Alain Vallon, mpfe
Dim ligneFin As Long, X As Long
Application.ScreenUpdating = False
ligneFin = ActiveSheet.UsedRange.Row - 1 +
ActiveSheet.UsedRange.Rows.Count
Application.ScreenUpdating = False
For X = ligneFin To 1 Step -1
If Application.CountA(Rows(X)) = 0 Then
Rows(X).Delete
Next X
End Sub
'Da la lettere di una colonna
Function ColLetter(cell As Range)
'Alain Vallon, Laurent Longre, mpfe
ColLetter = Left$(cell.Address(0, 0),
(cell.Column < 27) + 2)
End Function
Sub test()
MsgBox ColLetter(ActiveCell)
End Sub
Numero esempio :
93
Titolo : Nascondare_diverse_Righe_e_colonne
Autore : L. Mortezai
Commento : Una macro semplice per nascondere le righe e le colonne.
E chiesto attraverso delle inputbox.
Attribute VB_Name =
"NascondareRigheColonne"
Nascondare diversi Righe e colonne
Sub NascondereRighe()
Dim lignedebut, lignefin
lignedebut = InputBox("Prima riga a
nascondere", "Nascondere le righe")
If lignedebut = "" Then Exit Sub
lignefin = InputBox("ºUltima riga a
nascondere", "Nascondere le righe")
If lignefin = "" Then Exit Sub
ActiveSheet.Rows(lignedebut & ":" &
lignefin).Hidden = True
End Sub
Sub NascondereColonne()
Dim deb, fin
deb = InputBox("Prima colonna a nascondere :")
If deb = "" Then Exit Sub
fin = InputBox("Ultima colonna a nascondere
:")
If fin = "" Then Exit Sub
If IsNumeric(deb) Then deb = NomCol(CInt(deb))
If IsNumeric(fin) Then fin = NomCol(CInt(fin))
ActiveSheet.Columns(deb & ":" & fin).Hidden =
True
End Sub
Private Function NomCol(numcol As Integer) As
String
L. MortÚzai
NomCol = Chr(((numcol - 1) Mod 26) + 65)
If numcol > 26 Then NomCol = Chr((numcol - 1)
26 + 64) & NomCol
End Function
Numero esempio :
94
Titolo : Fare_una_cella_quadrata
Autore : StÚphane Royer, mpfe
Commento : Come fare per mette automaticamente le celle quadrate ?
Questa macro vi lo fa.
Attribute VB_Name =
"MettereCellePotenteQuadrata"
Sub Quadrata()
With Range("A1:K10")
.ColumnWidth = .Height * .ColumnWidth / .Width
End With
End Sub
Sub CellaQuadratta()
'GeeDee, mpfe
twips = 1 / 72
Application.WindowState = xlMaximized
ActiveWindow.Zoom = 100
Maxl = ActiveWindow.UsableWidth
MaxH = ActiveWindow.UsableHeight
NBC = InputBox("Numero di colonne visibili
volute")
taillecel = Int(Maxl / NBC)
elargir = True
i = 0
Application.ScreenUpdating = False
With ActiveSheet
While elargir
i = i + 1
.Cells.ColumnWidth = i * twips
.Cells.RowHeight = taillecel
elargir = (.Cells(1, 2).Left < taillecel)
Wend
Application.ScreenUpdating = True
rep = MsgBox("Larghezza di colonna : " & i *
twips & Chr(10) _
& "Altezza di riga : " & taillecel,
vbInformation, _
"GeeDee Celle quadrate")
End With
End Sub
Numero esempio :
95
Titolo : Mettere_in_riga_dati_in_colonna
Autore : Srinivas Todupunoori, mpep
Commento : Permette di mettere in riga i dati scelti che sono in
colonna (eguale a Incolla speciale => trasponi).
Public Sub
ConstructBIGString()
Dim rngColumn As Range
Dim lngEndRow As Long
Dim objCell As Range
Dim strContents As String
' Trova l'ultima riga
Range("H65536").End(xlUp).Select
lngEndRow = Selection.Row
Set objCell = Range("H1")
While objCell.Row <= lngEndRow
If objCell.Value <> "" Then
strContents = strContents & Chr(32) &
objCell.Value
End If
Set objCell = objCell.Offset(1, 0)
Wend
Range("A1") = strContents
End Sub
Numero esempio :
96
Titolo : contare_le_righe_visibili_di_un_filtro
Autore : Benoit Marchand, mpfe
Commento : Conta soltanto le righe visibili dopo avere applicato un
filtro sui dati. Ci sono tre macro diverse per farlo.
Sub DM3()
3 metode con SpecialCells de Benoit Marchand,
mpfe
Dim PlageUtile As Range
Col% = 1
' -1-
lig1 =
ActiveSheet.AutoFilter.Range.Columns(Col).
_
SpecialCells(xlCellTypeVisible).Cells.Count
lig1 = lig1 - 1 'per intestazione di colonna
' -2-'
With ActiveSheet.UsedRange
Set PlageUtile = .Offset(1,
0).Resize(.Rows.Count - 1 Col)
End With
lig2 = Intersect(PlageUtile,
ActiveSheet.AutoFilter .R ang e.Columns(Col). _
SpecialCells(xlCellTypeVisible)). Ce lls
.Count
' -3-
Set maplage =
ActiveSheet.AutoFilter.Range.Columns( Co l). _
SpecialCells(xlCellTypeVisible)
For Each Plage In maplage.Areas
lig3 = lig3 + Plage.Rows.Count
Next
lig3 = lig3 - 1 'pour l'entÛte
MsgBox "lig1=" & lig1 & vbCr & "lig2=" & lig2
& vbC r & " lig3 =" & lig3
End Sub
Function Numero_righe_filtratte(PlageFiltree
As Range )
Dim PlageUtile As Range
With PlageFiltree
Set PlageUtile = .Offset(1,
0).Resize(.Rows.Count - 1 1)
End With
NbLignesFiltrees = _
Intersect(PlageUtile, ActiveSheet.AutoFil te
r.R ange.Columns(1). _
SpecialCells(xlCellTypeVisible)).Cells.Co un t
End Function
'Prova la funzione Numero_righe_filtratte
Sub test1()
MsgBox NbLignesFiltrees(Range("C1:C35"))
End Sub
'**********************************
Sub comptLne()
' metoda con la proprieta visibile, ChrisV &
fs
Dim NbC As Long
Dim C As Range
Application.ScreenUpdating = False
NbC = 0
For Each C In Selection.Range("A1:A" &
Selection.Ro ws .Count - 1)
If Not C.EntireRow.Hidden Then NbC = (NbC + 1)
Next C
MsgBox NbC
End Sub
'Da ChrisV
Function CptLiFiltrees(Plage As Range)
Dim NbC As Long
Dim C As Range
NbC = 0
For Each C In Plage.Range("A1:A" &
Plage.Rows.Count - 1)
If Not C.EntireRow.Hidden Then NbC = (NbC + 1)
Next C
CptLiFiltrees = NbC - 1 'per cancelare la riga
d'intestazione
End Function
'prova la funzione CptLiFiltrees
Sub test2()
MsgBox CptLiFiltrees(Range("C1:C35"))
End Sub
Numero esempio :
97
Titolo : Funzione_numero_valori_Visibili
Autore :
Commento : Una funzione per contare il numero di celle visibili in
una zona.
Function
NB_SE_VISIBILE(Plage As Range, ValACompter)
Dim Compte As Long, cell As Range
Application.Volatile
Compte = 0
For Each cell In Plage
If Not cell.EntireRow.Hidden Then
If cell.Value = ValACompter Then
NB_SE_VISIBILE = NB_SE_VISIBILE + 1
End If
End If
Next cell
End Function
Numero esempio :
98
Titolo : contare_le_righe_visibile_di_un_filtro_2
Autore : JE Mc Gimpsey, mpep
Commento : Permette di contare il numero di righe visibili dopo
avere applicato un filtro sui dati. Due macro.
Sub RigaVisibile()
JE Mc Gimpsey, mpep
'Cancella la prima riga
Set rng = _
ActiveSheet.Range("A1:A" & Range("A" &
Rows.Count).End(xlUp).Row)
numRows = rng.SpecialCells(xlVisible).Count -
1
MsgBox numRows
End Sub
Sub AvecSousTotal()
'William, mpep
'Cancella la prima riga
MsgBox Application.Subtotal(3, Range("B:B")) -
1
End Sub
Numero esempio :
99
Titolo : Nome_del_colore_di_una_cella_3
Autore : fs
Commento : Permette di dare il nome del colore (e non l'indice) di
una cella.
Public tabColors(1 To 40, 1 To 2)
Function Colore(cell) As String
'Da il nome del colore a partire dell'indice
Application.Volatile
InitNomsCouleurs
If cell.Interior.ColorIndex < 0 Then
Couleur = "(Aucune)"
Else
Couleur =
Application.WorksheetFunction.VLookup( _
cell.Interior.ColorIndex, tabColors, 2, True)
End If
End Function
Private Sub InitNomsCouleurs()
'Crea la tabella che da il nome del colore
secondo l'indice
tabColors(1, 1) = 1: tabColors(1, 2) = "Nero"
tabColors(2, 1) = 2: tabColors(2, 2) =
"Bianco"
tabColors(3, 1) = 3: tabColors(3, 2) = "Rosso"
tabColors(4, 1) = 4: tabColors(4, 2) = "Verde
brillante"
tabColors(5, 1) = 5: tabColors(5, 2) = "Blu"
tabColors(6, 1) = 6: tabColors(6, 2) =
"Giallo"
tabColors(7, 1) = 7: tabColors(7, 2) = "Rosa"
tabColors(8, 1) = 8: tabColors(8, 2) =
"Turquese"
tabColors(9, 1) = 9: tabColors(9, 2) = "Rosso
scuro"
tabColors(10, 1) = 10: tabColors(10, 2) =
"Verde"
tabColors(11, 1) = 11: tabColors(11, 2) = "Blu
scuro"
tabColors(12, 1) = 12: tabColors(12, 2) =
"Marrone chiaro"
tabColors(13, 1) = 13: tabColors(13, 2) =
"Viola"
tabColors(14, 1) = 14: tabColors(14, 2) =
"Blu-verde"
tabColors(15, 1) = 15: tabColors(15, 2) =
"Grigio-25%"
tabColors(16, 1) = 16: tabColors(16, 2) =
"Grigio-50%"
tabColors(17, 1) = 33: tabColors(17, 2) = "Blu
cielo"
tabColors(18, 1) = 34: tabColors(18, 2) =
"Turquese chiara"
tabColors(19, 1) = 35: tabColors(19, 2) =
"Verde chiaro"
tabColors(20, 1) = 36: tabColors(20, 2) =
"Giallo chiaro"
tabColors(21, 1) = 37: tabColors(21, 2) = "Blu
medio"
tabColors(22, 1) = 38: tabColors(22, 2) =
"Rosa salmone"
tabColors(23, 1) = 39: tabColors(23, 2) =
"Lavanda"
tabColors(24, 1) = 40: tabColors(24, 2) =
"Bruno"
tabColors(25, 1) = 41: tabColors(25, 2) = "Blu
chiaro"
tabColors(26, 1) = 42: tabColors(26, 2) =
"Verde d'acqua"
tabColors(27, 1) = 43: tabColors(27, 2) =
"Limone verde"
tabColors(28, 1) = 44: tabColors(28, 2) =
"Oro"
tabColors(29, 1) = 45: tabColors(29, 2) =
"Arancia chiaro"
tabColors(30, 1) = 46: tabColors(30, 2) =
"Arancia"
tabColors(31, 1) = 47: tabColors(31, 2) =
"Blu-grigio"
tabColors(32, 1) = 48: tabColors(32, 2) =
"Grigio-40%"
tabColors(33, 1) = 49: tabColors(33, 2) =
"Blu-verde scuro"
tabColors(34, 1) = 50: tabColors(34, 2) =
"Verde marino"
tabColors(35, 1) = 51: tabColors(35, 2) =
"Verde scuro"
tabColors(36, 1) = 52: tabColors(36, 2) =
"Verde oliva"
tabColors(37, 1) = 53: tabColors(37, 2) =
"Marrone"
tabColors(38, 1) = 54: tabColors(38, 2) =
"Susina"
tabColors(39, 1) = 55: tabColors(39, 2) =
"Indigo"
tabColors(40, 1) = 56: tabColors(40, 2) =
"Grigio-80%"
End Sub
Numero esempio :
100
Titolo : Nome_del_colore_di_una_cella_2
Autore : Alain Vallon, mpfe
Commento : Una funziona che permette di sapere il nome del colore
per il fondo di una cella o per il colore del tipo di carattere.
Function CouleurCell(Cell, Optional
TypeCouleur As Integer = 0) As String
Alain Vallon, mpfe
'TipeCoulore 1 -> Colore del carattere
'Un altro valore -> Colore del fondo
Dim x As Long
Application.Volatile
Select Case TypeCouleur
Case 1: x = Cell.Font.ColorIndex
Case Else: x = Cell.Interior.ColorIndex
End Select
If x < 0 Then
CouleurCell = "(Aucune)"
Else
CouleurCell = Switch(x = 1, "Nero", x = 2,
"Bianco", x = 3 "R osso", _
x = 4, "Verde brillante", x = 5, "Blu", x = 6,
"Giallo ", x = 7, "Rosa", _
x = 8, "Turquese", x = 9, "Rosso scuro", x =
10, "Verd e", x = 11, _
"Blu curo", x = 12, "Marrone chiaro", x = 13,
"Viola", x 1 4, _
"Blu-verde", x = 15, "Grigio-25%", x = 16,
"Grigio-50% ", x = 33, _
"Blu cielo", x = 34, "Turquese chiara", x =
35, "Verde ch iar o", _
x = 36, "Giallo chiaro", x = 37, "Blu medio",
x = 38, "Ro sa salmone", _
x = 39, "Lavanda", x = 40, "Bruno", x = 41,
"Blu chiar o", x = 42, _
"Verde d'acqua", x = 43, "Limone-verde", x =
44, "Oro" , x = 45, "Arancia chiaro", _
x = 46, "Arancia", x = 47, "Blu-grigio", x =
48, "Grig io- 0,4 ", x = 49, _
"Blu-verde scuro", x = 50, "Verde marino", x =
51, "Ve rde sc uro", x = 52, _
"Verde oliva", x = 53, "Marrone", x = 54,
"Susina", x 5 5 "Indigo", _
x = 56, "Grigio-80%")
End If
End Function
Numero esempio :
101
Titolo : Numero_di_riga_della_cella_attiva_per_un_filtro
Autore :
Commento : Permette di sapere il numero della riga della cella
attiva, quando è stato applicato un filtro.
Sub Demo()
MsgBox GetFilteredRow(2)
End Sub
Function GetFilteredRow(VisRow As Long) As
Long
'Jim Rech, mpep
Dim Area As Range, Cell As Range
Dim Counter As Long, Ans As Long
VisRow = VisRow + 1 ''Add 1 for header
With
Range("_FilterDatabase").Columns(1).SpecialCells(xlCellTypeVisible)
For Each Area In .Areas
For Each Cell In Area
Counter = Counter + 1
If Counter = VisRow Then
Ans = Cell.Row
Exit For
End If
Next
If Ans <> 0 Then
GetFilteredRow = Ans
Exit For
End If
Next
End With
End Function
Numero esempio :
102
Titolo : Operazione_sulle_colonne
Autore : Dana DeLouis, mpep
Commento : Fare dei calcoli semplici tra due colonne. Questo esempio
usa le colonne a e B per i dati e la colonna C per il risultato,
potete modificare a voglia.
Sub OperationsSurPlages()
MsgBox "Multiplica i valori della colonna A
per quelli della colonna B"
[C1:C20000] = [(A1:A20000)*(B1:B20000)]
' 'ou
MsgBox "Divisa valori della colonna A per
quelli della colonna B"
[C1:C20000] = [(A1:A20000)/(B1:B20000)]
' 'ou
MsgBox "sottra valori della colonna A con
quelli della colonna B"
[C1:C20000] = [(A1:A20000)-(B1:B20000)]
' 'ou
MsgBox "Aggiunge valori della colonna A con
quelli della colon na B"
[C1:C20000] = [(A1:A20000)+(B1:B20000)]
MsgBox "Terminato"
End Sub
Numero esempio :
103
Titolo : Zona_nominata_nella_formula
Autore : Denis Michon, mpfe
Commento : Individua i riferimenti quando la formula usa una zona
nominata.
Sub
IndividuareZonaNominata()
Dim LeNom As String
Dim Rg As Range
Dim C As Range
On Error Resume Next
LeNom = Application.InputBox("Nome della zona
nominata e", , , , , , , 2)
If Err <> 0 Then Err = 0
If LeNom = "" Then Exit Sub
Set Rg = ActiveSheet.UsedRange.SpecialCells(xl
Ce ll Typ eFormulas)
For Each C In Rg
If InStr(1, C.Formula, LeNom, vbTextCompare) >
0 Th en
C.Interior.ColorIndex = 6
Else
C.Interior.ColorIndex = xlNone
End If
Next
End Sub
Numero esempio :
104
Titolo : Dare_valori_unici
Autore : fs
Commento : Ritorna una tabella con dei valori unici (senza doppi) di
una zona.
Function
ZonaSenzadoppi(Plage As Range, _
Optional Trié As Boolean = False)
fs, mpfe
'la zona è messa in una tabella
Dim Arr, Coll As New Collection
Dim i&, j&
Arr = Plage.Value
On Error Resume Next
For j = 1 To UBound(Arr, 2)
For i = 1 To UBound(Arr, 1)
Coll.Add Arr(i, j), CStr(Arr(i, j) )
Next i
Next j
On Error GoTo 0
ReDim Arr(1 To Coll.Count, 1 To 1)
For i = 1 To Coll.Count
Arr(i, 1) = Coll(i)
Next i
If Trié Then
'smista la tabella
End If
ZonaSenzadoppi = Arr
End Function 'fs
Sub test()
Dim Arr, i&
Arr = ZonaSenzadoppi(Range("A1:B 500 0"))
For i = LBound(Arr) To UBound(Arr)
Range("D" & i).Value = Arr(i, 1)
Next i
End Sub
Numero esempio :
105
Titolo : Verificare_se_una_zona_è_vuota_o_non
Autore : Jos Vens, mpep
Commento : Questa funzione permette di sapere se una zona è vuota o
non l'è.
Function
IS_Empty(vRange As Range) As Boolean
Jos Vens, mpep
IS_Empty = (vRange.Count -
Application.CountBlank(vRange) = 0)
End Function
Sub test()
MsgBox IS_Empty(Range("A1:A10"))
End Sub
Numero esempio :
106
Titolo : Indirizzo_delle_celle_visibili_filtrate
Autore :
Commento : Ritorna gli indirizzi delle celle visibili di una zona,
dopo avere applicato un filtro.
Sub VisibileDopoFiltro()
Dim PlageVisible As Range
Set PlageVisible = _
ActiveSheet.AutoFilter.Range.SpecialCells(xlCellTypeVisible)
MsgBox PlageVisible.Address
End Sub
Sub VisibleApresFiltre2()
'un altra metoda (permette di togliere la
prima riga - intestazione)
Dim PlageVisible As Range
'plage de données en C1:D30
Set PlageVisible = _
Range(Cells(2, 3), Cells(30,
4)).SpecialCells(xlCellTypeVisible)
PlageVisible.Select
End Sub
Numero esempio :
107
Titolo : Più_di_3_condizioni_formattazione_condizionale
Autore : Benoît Marchand, mpfe
Commento : Excel limita la formattazione condizionale a tere
condizioni, questa macro permette di deviare il problema usando la
funzione Switch.
Sub
FormattazioneCondizionale()
Dim wCell As Range, v As Variant, Nbre As
Boolean
For Each wCell In ActiveSheet.UsedRange
v = wCell.Value
If IsNumeric(wCell.Value) Then
wCell.Interior.ColorIndex = _
Switch( _
v = 2000, 1, _
v = 1999, 2, _
v = 450, 3, _
v = 350, 4, _
v = 200, 5, _
v = 150, 6, _
v = 100, 7)
Else
wCell.Interior.ColorIndex = 0
End If
Next wCell
End Sub
Numero esempio :
108
Titolo : Usare_la_funzione_range
Autore : Vasant Nanavati, mpep
Commento : Usare la proprieta "default" della funzione range.
Sub DumpArray()
Vasant Nanavati, mpep
Dim MyArray(1 To 5), i As Integer
For i = 1 To 5
MyArray(i) = i ^ 2
Next
For i = 1 To 5
'Usa la prorieta _Default dell'oggetto Range
Range("D5:E9")(i, 1) = MyArray(i)
Range("D5:E9")(i, 2) = MyArray(i) * 10
Next
'altro esempio
Range("D5:E9").Select
MsgBox Selection(2, 2).Address
End Sub
Numero esempio :
109
Titolo : Copiare_ultima_riga
Autore :
Commento : Permette di copiare l'ultima riga di una zona, sotto
l'ultima riga di un'altro foglio.
Sub CopieDerniereLigne()
Dim DerLi1 As Long, PremLi2 As Long
'ultima riga della zona selezionata
DerLi1 = Selection.Cells(Selection.Rows.Count,
1).Row
'prima riga vuota del foglio2
PremLi2 = Foglio2.Cells(Foglio2.UsedRange.Row
+ _
Feuil2.UsedRange.Rows.Count, 1).Row
Range("A" & DerLi1).EntireRow.Copy
Feuil2.Range("A" & PremLi2)
End Sub
Numero esempio :
110
Titolo : Sapere_lettera_colonna2
Autore :
Commento : Una funzione per conoscere la lettere della colonna dal
numero.
Function
ColLetter$(ColNumber)
Dim S$
If ColNumber < 1 Or ColNumber > 25 6 Th en
Exit Function
S = Cells(1, ColNumber).Address(1, 0)
ColLetter = Left(S, InStr(1, S, "$ ") - 1)
End Function 'fs
Sub test()
MsgBox ColLetter(30)
End Sub
Numero esempio :
111
Titolo : Sapere_lettera_colonna
Autore : Laurent Mortézai, mpfe
Commento : Otto funzioni per conoscere la lettera della colonna dal
numero.
Se non riuscite con ameno una delle otto...
Function
NomCol(numcol As Integer) As String
NomCol = Chr(((numcol - 1) Mod 26) + 65)
If numcol > 26 Then NomCol = Chr((numcol - 1)
26 + 64) & NomCol
End Function
'da la lettera della colonna
' (Excel 2000 et +)
'd'après Dana DeLouis, mpep
Function NomCol(Numero) As String
NomCol = Split(Cells(1, Numero).Address,
"$")(1)
End Function 'fs
'stessa cosa
'Iwer Mørck, mpep
Function LtrCol(Numero)
x = InStr(Mid(Cells(1, Numero).Address, 2),
"$") - 1
LtrCol = Mid(Cells(1, Numero).Address, 2, x)
End Function 'fs
'stessa cosa
Function ColumnLetter(ColNum As Integer) As
String
'Bernie Deitrick, mpep
Dim LastColLtr As String
LastColLtr = Cells(1, ColNum).Address
ColumnLetter = Mid(LastColLtr, 2, InStr(2,
LastColLtr, "$") - 2)
End Function
'********************************************************
'********con una cella come parametro*********
'********************************************************
' LL
Function LettreCol(cell As Range)
'usa il fatto che True vale -1 e False 0 per
informare
'il secondo parametro di Left (numero di
carattere a tenire)
LettreCol = Left$(cell.Address(0, 0),
(cell.Column < 27) + 2)
End Function
'Dana DeLouis, mpep (Excel 2000 et +)
Function ColLetter(cell As Range)
ColLetter = Split(cell.Address, "$")(1)
End Function
'Don Guillett, mpep
Function LaColonne(cell As Range)
LaColonne = Left(cell.Address(0, 0), 1 -
(cell.Column > 26))
End Function
'Iwer Mørck, mpep --> tutte versioni
Function ColLtr(cell As Range)
x = InStr(Mid(cell.Address, 2), "$") - 1
ColLtr = Mid(cell.Address, 2, x)
End Function
Numero esempio :
112
Titolo : Cambiare_nome_di_una_cella
Autore :
Commento : Permette di cambiare il nome definito di una cella o di
una zona.
Sub CambiaNomeCella(Nom$, NouvNom$)
Dim Adr
If Nom = "" Or NouvNom = "" Then Exit Sub
'da l'indirizzo
Adr = Range(Nom).Name
'sopprime il nome
Range(Nom).Name.Delete
'da il nuovo nome
Range(Adr).Name = NouvNom
End Sub 'fs
Sub test()
CambiaNomeCella "zaza", "toto"
End Sub
Numero esempio :
113
Titolo : Cambiare_punti_con_virgule
Autore : fs, mpfe
Commento : Permette di cambiare i punti con delle virgole. In
effetti, con Excel, secondo l'impostazione del computer, i calcoli
si fanno o non.
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
Numero esempio :
114
Titolo : Vedere_il_cursor_con_una_riga
Autore : Benead, mpfe
Commento : Permette di evidenziare la riga intera della cella
attiva, usando la formattazione condizionale.
Option Explicit
Sub AjoutConditionRègle()
[A1].Activate
With Cells
.FormatConditions.Delete
.FormatConditions.Add Type:=xlExpression,
Formula1:="=NumLig=LIGNE(A1)"
With .FormatConditions(1).Borders(xlBottom)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = 5
End With
.FormatConditions.Add Type:=xlExpression,
Formula1:="=NumCol=COLONNE(A1)"
With .FormatConditions(2).Borders(xlLeft)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = 3
End With
End With
End Sub
' ************* Nel modulo ThisWorkbook
**********
'Private Sub
Workbook_SheetSelectionChange(ByVal Sh As Object, ByVal Target As
Excel.Range)
' ThisWorkbook.Names.Add "NumLig", Target.Row
' ThisWorkbook.Names.Add "NumCol",
Target.Column
'End Sub
Numero esempio :
115
Titolo : Ripetere_righe_in_basso
Autore :
Commento : Fa : Modifica => riempimento => verso il basso, per una
riga intera.
Public AddedRows As
Range
Sub RipetereRigaInBasso()
Dim nbLiRep%, nbLiPage%, nbLiCorps%, Sel As
Range, totalLi%
Dim CurAdded As Range
On Error Resume Next
Set Sel = Application.InputBox _
("Righe a ripetere :", , , , , , , 8)
If Sel Is Nothing Then Exit Sub
nbLiPage = Sel.Range("A" & Sel.Rows.Count).Row
nbLiRep = Sel.Rows.Count
nbLiCorps = nbLiPage - nbLiRep
totalLi = ActiveSheet.UsedRange.Rows.Count
totalLi = totalLi + _
(nbLiRep * VBA.Round(totalLi / nbLiPage)) -
nbLiRep
Application.ScreenUpdating = False
Sel.Copy
For i = nbLiPage + 1 To totalLi Step nbLiPage
Rows(i + nbLiCorps).Insert.PasteSpecial
Set CurAdded = _
Rows(i + nbLiCorps & ":" & i + nbLiCorps +
nbLiRep - 1)
If i - 2 < nbLiPage Then
Set AddedRows = CurAdded
Else
Set AddedRows = Union(AddedRows, CurAdded)
End If
Sel.Copy
Next
Application.CutCopyMode = False
[A1].Select
End Sub
Sub SupprLignesEnBas()
AddedRows.EntireRow.Delete
End Sub
Sub RipetereRigaInBasso()
Dim nbLiRep%, nbLiPage%, nbLiCorps%, Sel As
Range, totalLi%
On Error Resume Next
Set Sel = Application.InputBox _
("Righe a ripetere in basso :", , , , , , , 8)
If Sel Is Nothing Then Exit Sub
nbLiPage = Sel.Range("A" & Sel.Rows.Count).Row
nbLiRep = Sel.Rows.Count
nbLiCorps = nbLiPage - nbLiRep
totalLi = ActiveSheet.UsedRange.Rows.Count
totalLi = totalLi + _
(nbLiRep * VBA.Round(totalLi / nbLiPage)) -
nbLiRep
Application.ScreenUpdating = False
Sel.Copy
For i = nbLiPage + 1 To totalLi Step nbLiPage
Rows(i + nbLiCorps).Insert.PasteSpecial
Sel.Copy
Next
Application.CutCopyMode = False
[A1].Select
End Sub
Numero esempio :
116
Titolo : selezionare_le_celle_non_protette_in_una_zona
Autore : Debra Dalgleish & Jake Marx, mpep
Commento : Seleziona soltanto le celle non protette di una zona (2
macro).
Sub GetUnlocked()
'Debra Dalgleish & Jake Marx, mpep
Dim c As Range
Dim rng As Range
For Each c In ActiveSheet.UsedRange
If Not (c.Locked) Then
If Not rng Is Nothing Then
Set rng = Union(c, rng)
Else
Set rng = c
End If
End If
Next c
rng.Select
End Sub
Sub SelectUnLocked()
'Søren Remfeldt, mpep
Dim Nonlocked As Range
Dim Found As Boolean
Found = False
lastrw =
Selection.SpecialCells(xlCellTypeLastCell).Row
lastclm =
Selection.SpecialCells(xlCellTypeLastCell).Column
For rowidx = 1 To lastrw
For clmidx = 1 To lastclm
If Cells(rowidx, clmidx).Locked = False Then
If Not Found Then
Found = True
Set Nonlocked = Cells(rowidx, clmidx)
Else
Set Nonlocked = Application.Union(Nonlocked,
Cells(rowidx, clmidx))
End If
End If
Next
Next
Nonlocked.Select
End Sub
Numero esempio :
117
Titolo : selezionare_le_celle_non_vuote_di_una_zona2
Autore : Pierre Fauconnier, Laurent Daurès, Denis Michon
Commento : Permette di selezionare le righe non vuote di una zona.
Sub CellePiene()
Dim FinalPlage As Range, MaPlage As Range,
LaPlage As Range
On Error Resume Next
ActiveSheet.UsedRange.Select
Set MaPlage =
Selection.SpecialCells(xlCellTypeFormulas)
If Not MaPlage Is Nothing Then Set FinalPlage
= MaPlage
Set LaPlage =
Selection.SpecialCells(xlCellTypeConstants)
If Not MaPlage Is Nothing And Not LaPlage Is
Nothing Then
Set FinalPlage = Union(MaPlage, LaPlage)
ElseIf Not LaPlage Is Nothing Then
Set FinalPlage = LaPlage
End If
If Not FinalPlage Is Nothing Then
FinalPlage.Select
End Sub
Numero esempio :
118
Titolo : selezionare_le_celle_non_vuote_di_una_zona
Autore : Dana DeLouis, mpep
Commento : Una funzione per selezionare le cella non vuote di una
zona.
Function Both() As
Range
Dana DeLouis, mpep
On Error Resume Next
Set C = Cells.SpecialCells(xlConstants)
Set F = Cells.SpecialCells(xlFormulas)
Set Both = Union(F, C)
If Both Is Nothing Then
Set Both = IIf(C Is Nothing, F, C)
End If
End Function
Sub test11()
MsgBox Both.Address
End Sub
Sub testBill()
'Bill Manville, mpep
Dim R As Range, S As Range
On Error Resume Next
Set R =
ActiveSheet.UsedRange.SpecialCells(xlConstants)
Set S =
ActiveSheet.UsedRange.SpecialCells(xlFormulas)
On Error GoTo 0
If R Is Nothing Then
Set R = S
ElseIf Not S Is Nothing Then
Set R = Union(R, S)
End If
' R is the range of non-blanks
If Not R Is Nothing Then MsgBox R.Address
End Sub
Sub const_form()
'Dave Peterson, mpep
Dim const_rng As Range
Dim form_rng As Range
Dim const_form_rng As Range
On Error Resume Next
Set const_rng =
Cells.SpecialCells(xlCellTypeConstants)
On Error GoTo 0
On Error Resume Next
Set form_rng =
Cells.SpecialCells(xlCellTypeFormulas)
On Error GoTo 0
On Error Resume Next
Set const_form_rng = Union(const_rng,
form_rng)
On Error GoTo 0
If const_form_rng Is Nothing Then
If Not const_rng Is Nothing Then
Set const_form_rng = const_rng
End If
If Not form_rng Is Nothing Then
Set const_form_rng = form_rng
End If
End If
MsgBox const_form_rng.Address
End Sub
Numero
esempio : 119
Titolo : Selezionare_le_celle_con_lo_stesso_formato
Autore : Pierre Fauconnier, mpfe
Commento : Mette le celle in rosso di tutte le celle che hanno lo
stesso formato della cella attiva
Sub FormatCellule()
Dim FormatNumerique As String
Dim Feuille As Worksheet, Cellule As Range,
Plage As Range
Dim FeuilleActive As Worksheet, CelluleActive
As Range
Set FeuilleActive = ActiveSheet
Set CelluleActive = ActiveCell
FormatNumerique = ActiveCell.NumberFormat
For Each Feuille In Worksheets()
Feuille.Select
Set Plage = _
Feuille.Range("a1",
ActiveCell.SpecialCells(xlCellTypeLastCell).Address)
For Each Cellule In Plage
If Cellule.NumberFormat = _
FormatNumerique Then Cellule.Interior.Color =
vbRed
Next Cellule
Next Feuille
FeuilleActive.Select
CelluleActive.Select
End Sub
'Crea una zona dello stesso formato che la
cella digitata nel parametro
Function CellulesMemeFormat(CellBase As Range)
As Range
Dim LeFormat$, Feuille As Worksheet, cell As
Range
Dim FeuilleActive As Worksheet, CellActive As
Range
Set FeuilleActive = ActiveSheet
Set CellActive = ActiveCell
LeFormat = CellBase.NumberFormat
Set CellulesMemeFormat = CellBase
For Each Feuille In ActiveWorkbook.Worksheets
Feuille.Activate
For Each cell In Feuille.UsedRange
If cell.NumberFormat = LeFormat Then
Set CellulesMemeFormat =
Union(CellulesMemeFormat, cell)
End If
Next cell
Next Feuille
FeuilleActive.Select
CellActive.Select
End Function
Sub testt()
Set Plage = CellulesMemeFormat(Range("B3"))
Plage.Select
End Sub
Numero esempio :
120
Titolo : Selezionare_le_celle_piene
Autore : Tom Ogilvy, mpep
Commento : Seleziona tutte le celle che contengono sia un data o una
formula.
Sub SelectAllData()
Dim rng As Range, rng1 As Range
Dim rng2 As Range
On Error Resume Next
Set rng2 = Cells.SpecialCells(xlFormulas)
Set rng1 = Cells.SpecialCells(x lCons ta nts)
On Error GoTo 0
If Not rng1 Is Nothing Then
If Not rng2 Is Nothing Then
Set rng = Union(rng1, rng2)
Else
Set rng = rng1
End If
Else
If Not rng2 Is Nothing Then
Set rng = rng2
Else
MsgBox "Sheet is blank"
Exit Sub
End If
End If
rng.Select
End Sub
Numero esempio :
121
Titolo : Somma_automatica
Autore :
Commento : Permette di fare una somma automatica di una zona creando
una barra di menu.
DoAutoSum()
Dim x As CommandBarControl
Set x = GetCommandObj(226)
If Val(Application.Version) = 10 Then Set x =
x.Controls(1)
x.Execute 'AutoSum
If Selection.Cells.Count = 1 Then
x.Execute 'Again to exit edit mode
End If
DelDummyBar
End Sub
'Crea una barra con l'icona "somma automatica"
Private Function GetCommandObj(CmdID As Long)
As Object
Dim Dummy As CommandBarControl
Set Dummy = CommandBars.FindControl(ID:=CmdID)
If Dummy Is Nothing Then
With CommandBars.Add("Temp", , , True)
Set Dummy = .Controls.Add(, CmdID)
End With
End If
Set GetCommandObj = Dummy
End Function
Private Sub DelDummyBar()
On Error Resume Next
Application.CommandBars("Temp").Delete
End Sub
Numero esempio :
122
Titolo : Somma_automatica
Autore : Xavier Vachy, mpfe
Commento : Permette di fare Somma_automatica come l'icona della
barra di strumenti.
Attribute VB_Name = "SommaAutomatica"
'Fa come il pulsante "Somma automatica"
d'Excel
Sub Somme_colonne_vers_le_haut()
Xavier Vachy, mpfe
' a l'inizio, la cella attiva è quella sotto
la cella
' con i dati a aggiungere
' Rivelare la zona
ActiveCell.Offset(-1, 0).Range("a1").Select
Range(ActiveCell, ActiveCell.End(xlUp)).Select
NbreLignes = Selection.Rows.Count
' Si posto dove deve essere la somma
ActiveCell.Offset(NbreLignes,
0).Range("a1").Select
' fare la somma !
ActiveCell.FormulaR1C1 = "=sum(R[-1]C:R[-" &
NbreLignes & "]C)"
End Sub
'stessa idea
Sub SommeAuDessus()
Dim NbLi&
NbLi = ActiveCell.Row -
ActiveCell(0).End(xlUp).Row
ActiveCell.FormulaR1C1 = "=SUM(R[-" & NbLi &
"]C:R[-1]C)"
End Sub 'fs
Sub SommeAuto()
'usa somma automatica d'Excel
Application.CommandBars("Auto
Sum").FindControl(ID:=226).Execute
'Fa con "ritorna"
'(esce e seleziona la cella seguente)
SendKeys "~"
End Sub 'fs
Sub SommeAuto2()
'sa somma automatica d'Excel
Application.CommandBars("Auto
Sum").FindControl(ID:=226).Execute
'Una seconda volta per chiudere
Application.CommandBars("Auto
Sum").FindControl(ID:=226).Execute
End Sub
Sub SommeAuto3()
'Jim Rech (Excel 2002)
'funziona anche se il pulsante Somma (Sigma
majuscule)
'non è piu nella barra di controli
SendKeys "{Enter 2}" 'come SommeAuto()
CommandBars.FindControl(ID:=226).Execute
End Sub
Numero esempio :
123
Titolo : Sommare_celle_colorate
Autore : L Longre, mpfe
Commento : Somma tutte le celle del colore della cella stabilita.
diverse funzioni per questa richiesta.
Function
SommeSiCouleur(myCells As Range) As Double
'L Longre, mpfe
Dim Arr, I As Long, J As Integer
Application.Volatile True
Arr = myCells
For I = 1 To UBound(Arr, 1)
For J = 1 To UBound(Arr, 2)
If myCells(I, J).Interior.ColorIndex > 0 Then
_
SommeSiCouleur = SommeSiCouleur + Arr(I, J)
Next J
Next I
End Function
'la stessa, però con la possibilità di
scegliere il colore
'per fare le celle *senza* colore, mettate
-4142 per il colore
Function SommeSelonCouleur(myCells As Range,
Couleur As Long) As Double
Dim Arr, I As Long, J As Integer
Application.Volatile True
Arr = myCells
For I = 1 To UBound(Arr, 1)
For J = 1 To UBound(Arr, 2)
If myCells(I, J).Interior.ColorIndex = Couleur
Then
SommeSelonCouleur = SommeSelonCouleur + Arr(I,
J)
End If
Next J
Next I
End Function
'stessa cosa
Function ColorCountIf(SearchArea As Object,
BgColor As Integer) As Integer
'S. Royer, mpfe
For Each cell In SearchArea
ColorCountIf = ColorCountIf +
Abs(cell.Interior.ColorIndex = BgColor)
Next cell
End Function
'per sapere il colore di una cella
Function Couleur(CkCell As Object)
'S. Royer, mpfe
Couleur = Abs(CkCell.Interior.ColorIndex)
End Function
Numero esempio :
124
Titolo : Sommare_celle_per_colore
Autore :
Commento : Somma le celle con dei colori similari.
Public tabCouleurs, tabColors(1 To 41,
1 To 2)
Sub MainMenu()
'Commando del menu della cella (clik destra)
'avviare una volta, o mettere nel Workbook_Add
in Install
Dim mCtrl As CommandBarPopup
Set mCtrl = Application.CommandBars("Cell").
_
Controls.Add(msoControlPopup, be fore: =1)
With mCtrl
.Caption = "Somme par couleur"
.OnAction = "AddCouleurs"
End With
End Sub
Private Sub AddCouleurs()
'aggiunge un commando nel menu della cella per
ogni colori presenti
Dim mCtrl As CommandBarPopup, bCtrl As Command
BarBu tton
Set mCtrl = Application.CommandBars("Cell"). _
Controls("Somme par couleur")
For I = mCtrl.Controls.Count To 1 Step -1
mCtrl.Controls(I).Delete
Next
'Colori usati
With mCtrl.Controls.Add(msoControlButton)
.Caption = "colori nel foglio :"
End With
For I = LBound(tabCouleurs) To UBound(tabCou
leurs )
With mCtrl.Controls.Add(msoControlButton)
.Caption = NomCouleur(tabCouleurs(I)) & " (" &
tabCouleurs(I) & ")"
.FaceId = 2170
.OnAction = "'Compte """ & tabCouleurs(I ) & "
""'"
End With
Next
' opzione per distruggere il menu
' Set bCtrl = mCtrl.Controls.Add(msoControlBu
tton)
' With bCtrl
' .Caption = "Destruggere questo menu"
' .FaceId = 3265
' .BeginGroup = True
' .OnAction = "DelMainMenu"
' End With
End Sub
Sub Compte(IndexCouleur)
'macro OnAction dei commandi aggiunti
Dim plage As Range, Msg$
Msg = "Selezionare la zona" & vbLf
Msg = Msg & "con le celle di colore '" & _
NomCouleur(CLng(IndexCouleur)) & "'" & vbLf
Msg = Msg & "volete aggiungere :"
'scelta della zona
On Error Resume Next
Set plage = Application.InputBox(Msg, "Somma
per colore", , , , , , 8)
If plage Is Nothing Then Exit Sub
'la cella attiva non deve essere nella zona
If Not Intersect(plage, ActiveCell) Is Nothing
Then
Msg = "La cella attiva fa parte della zona.
" & vbLf
Msg = Msg & "Rischio di riferimento con ciclo.
Cancella !"
MsgBox Msg, , "Somma per colore"
Exit Sub
End If
'se la cella attiva non è vuota
If Not IsEmpty(ActiveCell) Then
If MsgBox("La cella attiva non è vuta.
Prosegue e",
vbYesNo, _
"Somma per colore") = vbNo Then Exit Sub
End If
'da la formula nella cella attiva
ActiveCell.FormulaLocal = _
"=SommeSelonCouleur(" & plage.Address(0, 0) &
";" & CLng(IndexCouleur) & ")"
End Sub
'per fare la somma delle celle *senza* colore,
scrivere -4142 come colore
Function SommeSelonCouleur(Plage_à_examiner As
Range, _
Couleur_à_sommer As Long ) As Double
'L Longre, mpfe
Dim Arr, I As Long, J As Integer
Application.Volatile True
Arr = Plage_à_examiner
For I = 1 To UBound(Arr, 1)
For J = 1 To UBound(Arr, 2)
If Plage_à_examiner(I, J).Interior.Color Index
= _
Couleur_à_sommer The n
SommeSelonCouleur = SommeSelonCouleur(I, J)
End If
Next J
Next I
End Function
Sub DelMainMenu()
'destrugge il commando nel menu della cella
'
On Error Resume Next
Application.CommandBars("Cell"). _
Controls("Somma per colore").Delete
End Sub
Private Function NomCouleur(Idx) As String
'da il nome del colore della cella partire de
l'indice
' se questo modulo è usato in una "macro
aggiuntiva", mette questo
' in commento e mettetelo nel modulo Workbook
_Open
InitNomsCouleurs
For I = 1 To 41
If tabColors(I, 1) = Idx Then
NomCouleur = tabColors(I, 2)
Exit Function
End If
Next
End Function
Private Sub CouleursUtilisées()
'Da la tabella dei colori
'xlNone=-4142
Dim Vue As Boolean, I&, J&, cell As Range
Dim IdxCouleur&
I = 0
ReDim tabCouleurs(0)
For Each cell In ActiveSheet.UsedRange
If cell.Interior.ColorIndex <> -4142 Then
Vue = False
IdxCouleur = cell.Interior.ColorIndex
For J = LBound(tabCouleurs) To
UBound(tabCouleurs)
If tabCouleurs(J) = IdxCouleur Then
Vue = True: Exit For
End If
Next
If Not Vue Then
tabCouleurs(I) = IdxCouleur
I = I + 1
ReDim Preserve tabCouleurs(I)
End If
End If
Next
tabCouleurs(I) = -4142
End Sub
Sub InitNomsCouleurs()
'Fa la tabella dei colori secondo l'indice
'(Nel Workbook_Open)
tabColors(1, 1) = 1: tabColors(1, 2) = "Nero "
tabColors(2, 1) = 9: tabColors(2, 2) = "Rosso
scuro"
tabColors(3, 1) = 3: tabColors(3, 2) = "Ross
o"
tabColors(4, 1) = 7: tabColors(4, 2) = "Rosa"
tabColors(5, 1) = 38: tabColors(5, 2) = "Ros a
sal mone"
tabColors(6, 1) = 53: tabColors(6, 2) = "Mar
rone"
tabColors(7, 1) = 46: tabColors(7, 2) =
"Arancia"
tabColors(8, 1) = 45: tabColors(8, 2) = "Ara
ncia chiara"
tabColors(9, 1) = 44: tabColors(9, 2) = "Oro "
tabColors(10, 1) = 40: tabColors(10, 2) =
"Bruno"
tabColors(11, 1) = 52: tabColors(11, 2) = "V
erde oliva"
tabColors(12, 1) = 12: tabColors(12, 2) = "M
arron e chiaro"
tabColors(13, 1) = 43: tabColors(13, 2) = "L
imone verde"
tabColors(14, 1) = 6: tabColors(14, 2) = "Gi
allo"
tabColors(15, 1) = 36: tabColors(15, 2) = "J
Giallo chiaro"
tabColors(16, 1) = 51: tabColors(16, 2) =
"verde scuro"
tabColors(17, 1) = 10: tabColors(17, 2) =
"Verde"
tabColors(18, 1) = 50: tabColors(18, 2) =
"Verde marino"
tabColors(19, 1) = 4: tabColors(19, 2) =
"Verde brillante"
tabColors(20, 1) = 35: tabColors(20, 2) =
"Verde chiaro"
tabColors(21, 1) = 49: tabColors(21, 2) =
"Blu-verde scuro"
tabColors(22, 1) = 14: tabColors(22, 2) =
"Blu-verde"
tabColors(23, 1) = 42: tabColors(23, 2) =
"Verde d'acqua"
tabColors(24, 1) = 8: tabColors(24, 2) =
"Turquese"
tabColors(25, 1) = 34: tabColors(25, 2) =
"Turquese chiaro"
tabColors(26, 1) = 11: tabColors(26, 2) = "Blu
scuro"
tabColors(27, 1) = 5: tabColors(27, 2) = "Blu"
tabColors(28, 1) = 41: tabColors(28, 2) = "Blu
chiaro"
tabColors(29, 1) = 33: tabColors(29, 2) = "B
lu ci elo"
tabColors(30, 1) = 37: tabColors(30, 2) = "Blu
me dio"
tabColors(31, 1) = 55: tabColors(31, 2) =
"Indigo "
tabColors(32, 1) = 47: tabColors(32, 2) =
"Blu-grigio"
tabColors(33, 1) = 13: tabColors(33, 2) =
"Viola"
tabColors(34, 1) = 54: tabColors(34, 2) =
"Pruna"
tabColors(35, 1) = 39: tabColors(35, 2) =
"Lavanda"
tabColors(36, 1) = 56: tabColors(36, 2) =
"Grigio -80%"
tabColors(37, 1) = 16: tabColors(37, 2) =
"Grigio -50%"
tabColors(38, 1) = 48: tabColors(38, 2) =
"Grigio -40%"
tabColors(39, 1) = 15: tabColors(39, 2) =
"Grigio -25%"
tabColors(40, 1) = 2: tabColors(40, 2) =
"Bianco"
tabColors(41, 1) = -4142: tabColors(41, 2) =
"(Nessuno)"
End Sub
Numero
esempio : 125
Titolo : Sommare_le_celle_visibile
Autore : L Longre, mpfe
Commento : Somma tuttel e celle visibili di una zona
Function
SOMMEVISIBLE(Plage As Range) As Double
Dim Z As Range, C As Range
For Each Z In Plage.Columns
If Not Z.EntireColumn.Hidden Then _
If C Is Nothing Then Set C = Z Else Set C =
Union(Z, C)
Next Z
If C Is Nothing Then Exit Function
If C.Areas.Count = 1 And C.Columns.Count = 1
Th en
For Each Z In C.Cells
If Not Z.EntireRow.Hidden Then SOMMEVISIBLE =
SOMMEVISIBLE + Z
Next Z
Else
For Each Z In C.Rows
If Not Z.EntireRow.Hidden Then _
SOMMEVISIBLE = Application.Sum(SOMMEVISIBLE,
Z)
Next Z
End If
End Function
'se delle righe o delle colonne sono nascoste
dopo
'fare Ctrl-Maj-F9 per aggiornare
Numero
esempio : 126
Titolo : Sommare_una_zona_in_VBA
Autore :
Commento : Con VBA, permette di sommare una zona.
Attribute VB_Name =
"SommaUnaZona"
fare en VBA la somma di una spiaggia
Sub SommePlage()
Total = Evaluate("=sum(" & (Range("B2").Ad dre
ss (0, 0) & _
":" & Range("B2").End(xlDown).Address(0, 0) &
") "))
MsgBox Total
End Sub 'fs
Numero esempio :
127
Titolo : Sommare_le_celle_sotto_la_cella_attiva
Autore : Tom Ogilvy 5/9/01
Commento : Permette di sommare le celle che sono sotti la cella
attiva. Puo essere per una colonna o diverse colonne.
Sub AddItUp() ' Tom Ogilvy 5/9/01
Dim rng As Range
Dim dblSum As Double
With Worksheets("Feuil1")
Set rng = Range(.Cells(1, "E"), _
.Cells(Rows.Count, "E").End(xlUp))
End With
'Il numero di colonna è messo nella funzione
Resize (qui 1)
dblSum = Application.Sum(rng.Resize(, 1))
rng.Offset(rng.Rows.Count + 1, 0) _
.Resize(1, 1).Value = dblSum
End Sub
Numero esempio :
128
Titolo : Sommare_una_cella_in_tutti_i_fogli
Autore : Don Kline, mpep
Commento : Permette di sommare una cella per tutti i fogli senza
avere bisogno di selezionarli.
Public Function
SumAllWorkSheets(CurrCellRow, CurrCellColumn) As Double
'sum specified cell on all other worksheets in
workbook
Dim wb As Workbook
Dim sht As Worksheet
Dim SumAll As Double
Dim currsheetname As String
Application.Volatile True
Set wb = Application.Caller.Parent.Parent
SumAll = 0
currsheetname = Application.Caller.Parent.Name
For Each sht In wb.Sheets
If sht.Name <> currsheetname Then
SumAll = SumAll + sht.Cells(CurrCellRow,
CurrCellColumn)
End If
Next sht
SumAllWorkSheets = SumAll
End Function
Public Function SumAllWorkSheetsCurrCell() As
Double
'sums current cell on all other worksheets in
workbook
Dim wb As Workbook
Dim sht As Worksheet
Dim SumAll As Double
Dim currsheetname As String
Dim currcelladdress As String
Application.Volatile True
Set wb = Application.Caller.Parent.Parent
SumAll = 0
currsheetname = Application.Caller.Parent.Name
currcelladdress = Application.Caller.Address
For Each sht In wb.Sheets
If sht.Name <> currsheetname Then
SumAll = SumAll + sht.Range(currcelladdress)
End If
Next sht
SumAllWorkSheetsCurrCell = SumAll
End Function
Numero esempio :
129
Titolo : Sommare_celle_con_formato_condizionale
Autore :
Commento : Permette di sommare tutte le celle che hanno un formato
condizionale.
Sub SommeCondi()
Dim F$, cell As Range, Plage As Range,
resultat
On Error Resume Next
Set Plage = Application.InputBox("Zona a
sommare :", , , , , , , 8)
If Plage Is Nothing Then Exit Sub
For Each cell In Plage
cell.Activate
F = cell.FormatConditions(1).Formula1
If Evaluate(F) Then
resultat = resultat + cell.Value
End If
Next cell
Set Plage = Nothing
Set Plage = Application.InputBox _
("Dare il risultato nella cella :", , , , , ,
, 8)
If Plage Is Nothing Then Exit Sub
Plage.Value = resultat
End Sub
Numero esempio :
130
Titolo : Somma_se_colore
Autore : Pat
Commento : Permette di sommare le celle secondo lore colore.
Function
SumByColor(InputRange As Range, ColorRange As Range) As Double
Dim cl As Range, TempSum As Double, ColorIndex
As Integer
ColorIndex = ColorRange.Cells(1,
1).Interior.ColorIndex
TempSum = 0
On Error Resume Next ' non conta le celle
vuote
For Each cl In InputRange.Cells
If cl.Interior.ColorIndex = ColorIndex Then _
TempSum = TempSum + cl.Value
Next cl
On Error GoTo 0
Set cl = Nothing
SumByColor = TempSum
End Function
Numero esempio :
131
Titolo : Super_Concatenatore
Autore : Mark Lundberg, mpep
Commento : Concatenare di maniera semplice diverse celle.
SuperConcatenate(rInput As Range) As String
'Mark Lundberg, mpep
Dim rCell As Range
For Each rCell In rInput
SuperConcatenate = SuperConcatenate &
rCell.Text
Next
End Function
Function ConcatRange(Cellblock As Range) As
String
'J.E. McGimpsey, mpep
Dim cell As Range
For Each cell In Cellblock
ConcatRange = ConcatRange & cell.Value
Next
End Function
Numero esempio :
132
Titolo : sopprimere_le_righe_vuote
Autore : Myrna Larson, mpep
Commento : Permette di sopprimere le righe vuote (senza macro,
potete farlo di maniera semplice usando i filtri !)
Sub
DeleteEmptyRows()
Myrna Larson, mpep
Dim LastRow As Long
Dim R As Long
If WorksheetFunction.CountA(Cells) = 0 Then
MsgBox "foglio vuoto !"
Exit Sub
End If
With ActiveSheet.UsedRange
LastRow = .Cells(.Cells.Count).Row
End With
For R = LastRow To 1 Step -1
If WorksheetFunction.CountA(Rows(R)) = 0 Then
Rows(R).Delete
End If
Next R
End Sub
Numero esempio :
133
Titolo : Sopprimere#
Autore :
Commento : Quando la cella è troppo stretta per viualizare il
risultato di una formula, compare sulla cella il segno ####. Questa
macro permette di mettere al formato giusto tutte le celle troppo
strette.
Attribute VB_Name =
"Sopprimere#"
'mettere al buono formatto per evitare il
signo ######
Sub CellulesEtroites()
'Yvan, mpfe
Dim Plage, cel
Set Plage = ActiveSheet.UsedRange
For Each cel In Plage
If Left(cel.Text, 1) = "#" Then
Application.StatusBar = "La cella " & _
cel.Address & " è troppa st retta"
Range(cel.Address).EntireColumn. AutoFit
End If
Next cel
Application.StatusBar = False
End Sub
Numero esempio :
134
Titolo : Sopprimere_i_doppi_in_una_cella
Autore : Denis Michon, mpfe
Commento : Sopprime tutti i doppi di una cella.
Sub Doppi()
With Selection
.Range("A1").Sort Key1:=.Range("A1"),
Order1:=xlAscending
Set currentcell = .Range("A1")
Application.ScreenUpdating = False
Do While Not IsEmpty(currentcell)
Set nextcell = currentcell.Offset(1, 0)
If nextcell.Value = currentcell.Value Then
currentcell.Delete (xlUp)
End If
Set currentcell = nextcell
Loop
End With
End Sub
Numero esempio :
135
Titolo : Sopprimere_righe_se_celle_vuote
Autore : Tushar Mehta, mpep
Commento : Cancellare tutte le righe se non vuote.
Diverse macro.
Non funziona su una zona filtrata.
Sub
DeleteRowsWithAutoFilter()
aRng As Range, aWKS As Worksheet, _
aFilter As AutoFilter, DeleteRange As Range
Set aWKS = ActiveSheet
Set aFilter = aWKS.AutoFilter
If Not (aFilter Is Nothing) Then
MsgBox "Il filtro automatico è gia usato" & v
bCrLf _
& "Usate un'altra metoda per cancellare le
righe"
Exit Sub
End If
With aWKS.Range("a1")
.AutoFilter
.AutoFilter Field:=2, Criteria1:="="
Set DeleteRange = .Range(.Cells(2, 1),
.Cells(2, 1) .End(xlDown))
Set DeleteRange =
DeleteRange.SpecialCells(xlCel lTy peVisible).EntireRow
DeleteRange.Delete Shift:=xlUp
.AutoFilter
End With
End Sub
Sub DeleteWithFind()
'2- usa la funziona Find
Dim SearchRange As Range, FirstCell As Range,
Delete Ran ge As Range, _
FoundCell As Range, aWKS As Worksheet
Set aWKS = ActiveSheet
With aWKS
Set SearchRange = .Range(.Cells(1, 1),
.Cells(1, 1) .End(xlDown))
End With
Set SearchRange = SearchRange.Offset(0, 1)
Set FirstCell = SearchRange.Find(What:="", _
LookIn:=xlValues, _
SearchOrder:=xlByRows, SearchDirection:=xlNe
xt, _
MatchCase:=False, SearchFormat:=False)
If FirstCell Is Nothing Then 'nothing to
delete
Else
Set DeleteRange = FirstCell
Set FoundCell = FirstCell
Do
Set FoundCell = SearchRange.FindNext(FoundCell
)
On Error Resume Next
Set DeleteRange = Union(DeleteRange, FoundCell
)
On Error GoTo 0
Loop Until (FoundCell Is Nothing) _
Or (FoundCell.Address = FirstCell.Ad dre ss)
DeleteRange.EntireRow.Delete
End If
End Sub
Sub DeleteWithLoop()
Dim aCell As Range, DeleteRange As Range,
SearchRang e A s Range, _
aWKS As Worksheet
With aWKS
Set SearchRange = .Range(.Cells(1, 1),
.Cells(1, 1) .End(xlDown))
End With
Set SearchRange = SearchRange.Offset(0, 1)
For Each aCell In SearchRange
If aCell.Value <> "" Then
ElseIf DeleteRange Is Nothing Then
Set DeleteRange = aCell
Else
Set DeleteRange = Union(DeleteRange, aCell)
End If
Next aCell
If Not DeleteRange Is Nothing Then
DeleteRange.Ent ire Row.Delete
End Sub
Numero esempio :
136
Titolo : sopprimere_righe_secondo_una_condizione
Autore : Leo Heuser, 11. Nov. 2002, mpep
Commento : Permette di sopprimere le righe secondo una condizione
per esempio se non c'è un valore nella riga, la I valori sono
scritti nella tabella "CondiArray".
Sub
DeleteRowsConditionally()
Dim CheckColumn As Range
Dim CheckRange As Range
Dim CondiArray As Variant
Dim Counter As Long
Dim DeleteRange As Range
Dim FirstDataRow As Long
Dim SaveCondiRange() As Range
On Error Resume Next
CondiArray = Array(1, 2, 3, 4, 5, 6,
"Exampletext")
Set CheckColumn = ActiveSheet.Columns("A")
FirstDataRow = 2
With CheckColumn
Set CheckRange = Range(.Cells(FirstDataRow,
1), .Cells(65536, 1).End(xlUp))
End With
ReDim SaveCondiRange(UBound(CondiArray) -
LBound(CondiArray) + 1)
For Counter = LBound(SaveCondiRange) To
UBound(SaveCondiRange)
CheckRange.Replace _
What:=CondiArray(Counter), _
Replacement:="#N/A", _
LookAt:=xlWhole, _
MatchCase:=True
Set SaveCondiRange(Counter) = _
CheckRange.SpecialCells(xlCellTypeConstants,
xlErrors)
SaveCondiRange(Counter).Value =
CondiArray(Counter)
Next Counter
For Counter = LBound(SaveCondiRange) To
UBound(SaveCondiRange)
SaveCondiRange(Counter).Value = "#N/A"
Next Counter
Set DeleteRange = CheckRange. _
SpecialCells(xlCellTypeConstants, xlNumbers +
xlTextValues)
For Counter = LBound(SaveCondiRange) To
UBound(SaveCondiRange)
SaveCondiRange(Counter).Value =
CondiArray(Counter)
Next Counter
DeleteRange.EntireRow.Delete
End Sub
Numero esempio :
137
Titolo : sopprimere_righe
Autore : Johnno, mpep
Commento : Sopprimere le righe scelte in un foglio. Dovete scrivere
Del_Rows (nome della macro) e i numeri di righe, usando la virogla
per separarli.
Per esempio :
Del_Rows "5,8,11,15"
Attribute VB_Name =
"SopprimereRighe"
'sopprimere le righe in un foglio
Sub test()
Del_Rows "5,8,11,15"
End Sub
Public Sub Del_Rows(myvariant As String)
Johnno, mpep
Dim sR() As String
Dim i As Long
sR = Split(myvariant, ",")
'Delete Rows (Important: Step From Max To
Min!)
For i = UBound(sR) To LBound(sR) Step -1
Rows(sR(i)).Delete
Next
End Sub
Numero esempio :
138
Titolo : sopprimere_righe_doppie
Autore : fs, mpfe
Commento : Permette di sopprimere le righe identiche.
Sub
SopprRigheIdentiche()
fs, mpfe
Dim cell As Range, CellsToSuppr As Range,
derLi As Long
Application.ScreenUpdating = False
derLi = Cells(Rows.Count, 1).End(xlUp).Row
For i = 1 To derLi
If Cells(i, 1) = Cells(i + 1, 1) Then
If CellsToSuppr Is Nothing Then
Set CellsToSuppr = Cells(i + 1, 1)
Else: Set CellsToSuppr = Union(CellsToSuppr,
Cells(i + 1, 1))
End If
End If
Next i
If Not CellsToSuppr Is Nothing Then
CellsToSuppr.EntireRow.Delete
End Sub
Numero esempio :
139
Titolo : soprimere_righe_vuote
Autore : Misange, mpfe
Commento : Un'altra macro per sopprimere le righe vuote.
Sub SoppRigheVuote()
With ActiveSheet.UsedRange
derLi = .Row + .Rows.Count - 1
End With
Application.ScreenUpdating = False
For r = derLi To 1 Step -1
If Application.CountA(Rows(r)) = 0 Then
Rows(r).Delete
Next r
End Sub
Numero esempio :
140
Titolo : Sapere_se_una_cella_fa_parte_di_una_zona
Autore : J. Walkenbach, mpep
Commento : Questa funzione permette di sapere se una cella fa parte
di una zona.
Function
InRange(rng1, rng2) As Boolean
J. Walkenbach, mpep
' Returns True if rng1 is a subset of rng2
InRange = False
If rng1.Parent.Parent.Name =
rng2.Parent.Parent.Name Then
If rng1.Parent.Name = rng2.Parent.Name Then
If Union(rng1, rng2).Address = rng2.Address
Then
InRange = True
End If
End If
End If
End Function
Function Dedans(mg1, mg2) As Boolean
'AV et fs, mpfe
Dedans = Not (Intersect(mg1, mg2) Is Nothing)
End Function
Numero esempio :
141
Titolo : Sapere_se_una_cella_fa_parte_di_una_zona_nominata2
Autore : Chip Pearson, mpep
Commento : Se avete dato un nome ad una zona di celle, questa
funzione permette di sapere se una cella fa parte o non di questa
zona.
Attribute VB_Name =
"ProvaSeCellaInUnaSpiaggiaNominata2"
'If you want to test whether a cell is within
a specific named
'range, use something like
'(utilisation :
'If IsCellInRange(ActiveCell, "TheRangeName")
= True Then... )
Function IsCellInRange(Rng As Range, RangeName
As String ) As Boolean
'Chip Pearson, mpep
On Error Resume Next
IsCellInRange = _
Not (Application.Intersect(Rng,
Range(RangeName)) Is Not hing)
End Function
'If you want to determine *what* defined
range, if any, a ce ll may
'be in, use something like
Function WhatRangeIsCellIn(Rng As Range) As
String
'Chip Pearson, mpep
Dim Nm As Name
Dim ISect As Range
On Error Resume Next
For Each Nm In ThisWorkbook.Names
Set ISect = Application.Intersect(Rng,
Nm.RefersToRa nge)
If Not ISect Is Nothing Then
WhatRangeIsCellIn = Nm.Name
End If
Next Nm
End Function
'This function returns the first named range
which contains the
'cell, or an empty string if the cell is not
in any cell :
Sub testt()
Dim WhatRange As String
WhatRange = WhatRangeIsCellIn(ActiveCell)
If WhatRange = "" Then
' not in any named range
Else
Debug.Print "Cell is in : " & WhatRange
End If
End Sub
Numero esempio :
142
Titolo : Sapere_se_una_cella_fa_parte_di_una_zona_nominata
Autore : Bernie Deitrick, mpep
Commento : Controlla se la cella fa parte di una zona nominata, e se
fa parte, da il nome della zona.
Function
InNamedRanges(Optional inCell As Range) As String
Bernie Deitrick, mpep
Dim myName As Name
Dim myAddress As String
Dim myMessage As String
Dim myRange As Range
Dim inRange As Integer
Dim B As Range
If inCell Is Nothing Then Set inCell =
Application.Caller
myMessage = "Cella " & inCell.Address(False,
False) & " Non è in una zona nominata"
inRange = 0
On Error GoTo SkippedName
For Each myName In ActiveWorkbook.Names
myAddress = myName.RefersTo
Set B = Intersect(inCell, Range(myAddress))
If Not (B Is Nothing) Then
If inRange = 0 Then
inRange = 1
myMessage = "Cella " & B.Address(False, False)
& " è nella zona : " & myName.Name
Else: myMessage = myMessage & "; " &
myName.Name
End If
End If
SkippedName:
Next myName
InNamedRanges = myMessage
End Function
Numero esempio :
143
Titolo : Spostare_una_zona_verso_un_altra
Autore : Chip Pearson, mpep
Commento : Spsotare con facilità una zona.
2 macro.
Sub TansposeRange()
Chip Pearson, mpep
Dim FromRange As Range
Dim ToRange As Range
Set FromRange = Range("F1:H2")
Set ToRange =
Range("A10000").End(xlUp).Offset(1)
Set ToRange = _
ToRange.Resize(FromRange.Columns.Count,
FromRange.Rows.Count)
ToRange.Value =
Application.Transpose(FromRange)
End Sub
Sub Sposta()
'Alan Beban, mpep
Range("F1:H2").Copy
Range("C10000").End(xlUp).Offset(1).PasteSpecial Transpose:=True
Application.CutCopyMode = False
End Sub
Numero esempio :
144
Titolo : Spostare_dati_in_colonne
Autore :
Commento : Permette di spostare dei dati in riga verso diverse
colonne. Esempio :
prima :
'campo1
'campo2
'campo3
'
'campo1
'campo2
'campo3
'
'campo1
'campo2
'campo3
'dopo
'campo1 campo2 campo3
'campo1 campo2 campo3
'campo1 campo2 campo3
Sub SpostareRigheInColonne()
Dim Arr, NbLign esTranch e&, Colonne ATran
sposer&
NbLignesTranche = 4 ' deve essere cambiato
(numero riga)
Colonn eATrans poser = 1 ' (= colonna A) puo
essere cambiato
With S heets(" Foglio1" ) 'puo essere cambiato
Arr = .Rang e( _
.Ce lls(1, C olo nneATran spose r), _
.Ce lls(.Cel ls( .Rows.Co unt,
1).End(xlUp).Row, ColonneATransposer) _
).Value
End Wi th
k = 1
Sheets .Add
For i = LBoun d(Arr, 1 ) T o UBound (Arr, 1)
Step NbLignesTranche
For j = 1 T o NbLign esT ranche
If (i + j - 1) > UBo und(Arr, 1) T hen Exit
For
Ce lls(k, j).Value = Arr(i + j - 1 , 1)
Next
k = k + 1
Next
End Sub 'fs
Sub Transpoz()
'Sposta una zona nominata (in colonne)
y = 1
For x = 1 To Ra nge("lis te" ).Count Step 4
For i = 1 T o 4
Sheets( "Feuil2" ).C ells(y, i) =
Range("liste")(i + x - 1)
Next
y = y + 1
Next
End Sub 'AV
Numero esempio :
145
Titolo : Creare_delle_colonne_ogni_25_righe
Autore : Luther, mpep
Commento : Questa macro permette di prendere i dati ogni 25 righe e
metterli in colonne.
Sub SpostaColonne()
Luther, mpep
Application.ScreenUpdating = False
SOURCE_COL = 1
SOURCE_ROW = 1
PLACE_COL = 1
Do
For PLACE_ROW = 1 To 25 Step 1
Cells(PLACE_ROW, PLACE_COL).Value =
Cells(SOURCE_ROW, SOURCE_COL).Value
SOURCE_ROW = SOURCE_ROW + 1
Next PLACE_ROW
PLACE_COL = PLACE_COL + 1
Loop Until IsEmpty(Cells(SOURCE_ROW,
SOURCE_COL))
Range("A26:A65536").ClearContents
End Sub
Numero
esempio : 146
Titolo : Spostare_una_taella_su_una_colonna
Autore :
Commento :
Attribute VB_Name =
"SpostareUnaTabe llaSuU na Colonna"
'Sposta una tabella da X colonne per Y rig he
su una colonna
Sub ReduceToOneCol(Plage As Range)
Dim Col1%, derCol%, Li1&, LiDeb&
Dim ToCut As Range
Col1 = Plage.Range("A1").Column
derCol = Col1 + Plage.Columns.Coun t - 1
Li1 = Plage.Range("A1").Row
Application.ScreenUpdating = False
With Plage
For i = Col1 + 1 To derCol
LiDeb = .Range("A1").End(xlDow n).Row + 1
Set ToCut = .Range(.Cells(Li1, i), _
.Cells(.Cells(Li1, i).En d( xlDown).Row, i))
ToCut.Cut .Cells(LiDeb, Col1)
Next
End With
End Sub
Sub test()
ReduceToOneCol Range("A1:D35") ' < =-- puo e
ssere cambiare
End Sub
Numero esempio :
147
Titolo : Smistare_colonna_data
Autore : Pierre Fauconnier, mpfe
Commento : Questa macro permette di smistare tutte le date di una
colonna, senza considerare l'anno. Così, la colonna è smistata
secondo il giorno e il mese.
Sub SmistareData()
Dim Sel As Range
On Error Resume Next
Set Sel = Application.InputBox("Zona a
smistare :" , T ype :=8)
If Err <> 0 Then
Exit Sub
Else
TriDatesAnniversaire Sel, 1
End If
End Sub
Sub TriDatesAnniversaire(Plage As Range,
ColonneDate As Integer)
Dim Tableau, Compteur As Long
Dim Colonne As Long
Colonne = Plage.Columns.Count + 1
Tableau = Plage.Value2
ReDim Preserve Tableau(1 To Plage.Rows. Co
unt, 1 To Pl age .Columns.Count + 1)
For Compteur = 1 To UBound(Tableau)
Tableau(Compteur, Colonne) = _
Month(Tableau(Compteur, C olon ne Dat e)) * 32
+ _
Day(Tableau(Compteur, C ol onne Da te) )
Next Compteur
Tableau = TriABulles(Tableau)
ReDim Preserve Tableau(1 To UBound(Tabl ea u),
1 To UBound (Tableau, 2) - 1)
Plage.Value = Tableau
End Sub
Function TriABulles(Tableau)
Dim Compteur As Long, Compteur1 As Long
Dim CompteurColonne As Long
Dim ValTemp As Variant
For Compteur = 1 To UBound(Tableau)
For Compteur1 = Compteur + 1 To UBoun d( Tabl
ea u)
For CompteurColonne = 1 To UBound(T ab leau ,
2)
If Tableau(Compteur, UBound(Table au , 2) ) >
_
Tableau(Compteur1, UBound(Tableau, 2)) Then
ValTemp = Tableau(Compteur, CompteurColonne)
Tableau(Compteur, CompteurColon ne ) =
Tableau( Compteur1, CompteurColonne)
Tableau(Compteur1, CompteurColo nne) = ValTemp
End If
Next CompteurColonne
Next Compteur1
Next Compteur
TriABulles = Tableau
End Function
Numero esempio :
148
Titolo : Trovare_riferimenti_2
Autore : Daniel Lewis, mpep
Commento : Crea una tabella in cui sono scritti tutti i riferimenti
di una cella.
Function
GetDependents(rngCell As Range) As Variant
''' Returns a listing of all dependents of a
given cell
Daniel Lewis, mpep
Dim rngNextCell As Range
Dim rngCurrCell As Range
Dim intPrecCnt As Integer
Dim intListCnt As Integer
Dim intExtCnt As Integer
Dim strCurrSheet As String
Dim strCurrAddress As String
Dim strNextSheet As String
Dim strCurrWorkbook As String
Dim strNextWorkbook As String
Dim avTemp() As Variant
Dim boolDone As Boolean
Dim wksCurrent As Worksheet
Dim boolComplete As Boolean
''' Initialise variables
Set rngCurrCell = rngCell
strCurrSheet = rngCell.Worksheet.Name
strCurrWorkbook =
rngCurrCell.Worksheet.Parent.Name
strCurrAddress = rngCurrCell.Address
intPrecCnt = 0
intListCnt = 0
''' Show precedent arrows
rngCurrCell.Select
Application.ExecuteExcel4Macro
"TRACER.DISPLAY(FALSE,TRUE)"
''' Cycle through dependents
Do
intPrecCnt = intPrecCnt + 1
''' Move down arrow
Workbooks(strCurrWorkbook).Activate
Set rngNextCell =
rngCurrCell.NavigateArrow(False, intPrecCnt)
strNextSheet = rngNextCell.Worksheet.Name
strNextWorkbook =
rngNextCell.Worksheet.Parent.Name
''' If not external reference then add to list
If (strNextWorkbook = strCurrWorkbook) And
(strNextSheet = strCurrSheet) Then
intListCnt = intListCnt + 1
ReDim Preserve avTemp(3, intListCnt)
avTemp(1, intListCnt) = strNextWorkbook
avTemp(2, intListCnt) = strNextSheet
avTemp(3, intListCnt) = rngNextCell.Address
''' Else track external references
Else
''' Add details to list
intListCnt = intListCnt + 1
ReDim Preserve avTemp(3, intListCnt)
avTemp(1, intListCnt) = strNextWorkbook
avTemp(2, intListCnt) = strNextSheet
avTemp(3, intListCnt) = rngNextCell.Address
intExtCnt = 2
boolDone = False
Do
''' Get next external reference
Workbooks(strCurrWorkbook).Activate
''' If an error is raised when using
NavigateArrow there must be no more refs
On Error Resume Next
Set rngNextCell =
rngCurrCell.NavigateArrow(False, intPrecCnt, intExtCnt)
If Err.Number > 0 Then boolDone = True
Err.Clear
On Error GoTo 0
''' If precedent exists then list it
If Not boolDone Then
''' Get details
strNextSheet = rngNextCell.Worksheet.Name
strNextWorkbook =
rngNextCell.Worksheet.Parent.Name
''' Add to list
intListCnt = intListCnt + 1
ReDim Preserve avTemp(3, intListCnt)
avTemp(1, intListCnt) = strNextWorkbook
avTemp(2, intListCnt) = strNextSheet
avTemp(3, intListCnt) = rngNextCell.Address
''' Increment counter
intExtCnt = intExtCnt + 1
End If
Loop Until boolDone
End If
If strNextWorkbook <> strCurrWorkbook Or
strNextSheet <> strCurrSheet Then
boolComplete = False
ElseIf Application.Intersect(rngNextCell,
rngCurrCell) Is Nothing Then
boolComplete = False
Else
boolComplete = True
End If
Loop Until boolComplete
Workbooks(strCurrWorkbook).Activate
rngCurrCell.Select
Application.ExecuteExcel4Macro
"TRACER.DISPLAY(FALSE,FALSE)"
rngCurrCell.Worksheet.ClearArrows
GetDependents = avTemp
End Function
Numero
esempio : 149
Titolo : Trovare_riferimenti
Autore : Bill Manville
Commento : Crea una tabella in cui sono scritti tutti i riferimenti
di una cella.
Sub FindPrecedents()
written by Bill Manville
'revised by Paul S.
'August 14, 2001
' this procedure finds the cells which are
' the direct precedents of the active cell
Dim rLast As Range, iLinkNum As Integer,
iArrowNum As Integer
Dim stMsg As String
Dim bNewArrow As Boolean
Application.ScreenUpdating = False
ActiveCell.ShowPrecedents
Set rLast = ActiveCell
iArrowNum = 1
iLinkNum = 1
bNewArrow = True
Do
Do
Application.Goto rLast
On Error Resume Next
ActiveCell.NavigateArrow _
TowardPrecedent:=True, ArrowNumber:=iArrowNum,
_
LinkNumber:=iLinkNum
If Err.Number > 0 Then Exit Do
On Error GoTo 0
If rLast.Address(external:=True) = _
ActiveCell.Address(external:=True) Then Exit
Do
bNewArrow = False
If rLast.Worksheet.Parent.Name = _
ActiveCell.Worksheet.Parent.Name Then
If rLast.Worksheet.Name = _
ActiveCell.Parent.Name Then
' local
stMsg = stMsg & vbNewLine & _
Selection.Address
Else
stMsg = stMsg & vbNewLine & "'" & _
Selection.Parent.Name & "'!" & _
Selection.Address
End If
Else
' external
stMsg = stMsg & vbNewLine & _
Selection.Address(external:=True)
End If
iLinkNum = iLinkNum + 1 ' try another link
Loop
If bNewArrow Then Exit Do
iLinkNum = 1
bNewArrow = True
iArrowNum = iArrowNum + 1 'try another arrow
Loop
rLast.Parent.ClearArrows
Application.Goto rLast
MsgBox "Precedents are" & stMsg
Exit Sub
End Sub
Numero esempio :
150
Titolo : Cambiare_formule_per_valori
Autore :
Commento : Permette di togliere tutte le formule di un foglio,
scrivendo solo il risultato (Eguale a : Incolla Speciale => Valori).
Attribute VB_Name =
"Cambiar eF orm ulePerValori"
'Cancella tutte le formule
'e scrive i valori
Sub ValeursSeules()
Dim Sht As Worksheet
Application.ScreenUpdating = False
For Each Sht In Worksheets
With Sht
.Select
Range(.UsedRange.Address ) =
(Range(.UsedRange.Address))
End With
Next Sht
End Sub
Numero esempio :
151
Titolo : Da_i_valori_unici_in_una_colonna
Autore : Leo Heuser, mpep
Commento : Permette di tenire soltanto i valori unici di una
colonna, togliando i doppi.
Private Declare
Function GetTickCount Lib "kernel32" () As Long
Sub ColUnici()
Leo Heuser, mpep
Dim DataRange As Range
Dim DataArray As Variant
Dim i%
Dim Collection1 As New Collection
tm = GetTickCount
Set DataRange = Range("A1:A5000")
DataArray = DataRange.Value
On Error Resume Next
For Each Element In DataArray
Collection1.Add Element, CStr(Element)
Next Element
For i = 1 To Collection1.Count
Range("B" & i).Value = Collection1(i)
Next i
Columns("B").Sort [B1]
tm = GetTickCount - tm
MsgBox tm
End Sub
Sub UniqueList()
'Eero Tibar, mpep
tm = GetTickCount
Application.ScreenUpdating = False
[a1].Select
s = 5000
Columns("A:B").Insert
With Range("a1:a" & s)
.Value = Range("c1:c" & s).Value
.Sort Range("a1"), xlAscending
v = [a1]
With Range("b1:b" & s)
.Formula = "=if(a1<>a2,a2,"""")"
.Value = .Value
.Sort Range("b1"), xlAscending
[B1] = v
z = Range("b1").End(xlDown).Row
Range("D1:D" & z).Value = Range("b1:b" &
z).Value
End With
End With
Columns("A:B").Delete
tm = GetTickCount - tm
MsgBox tm
End Sub
Numero esempio :
152
Titolo : Visualizzare_le_celle_unite
Autore : JE McGimpsey, mpep
Commento : Permette di sottolineare le celle unite.
Sub
ColorierCellulesFusionnees() <b
Dim rng As Range
Dim cell As Range
With ActiveSheet.UsedRange
For Each cell In .Cells
With cell
If .Interior.ColorIndex = xlNone Then
If .MergeCells = True Then
.MergeArea.Interior.ColorIndex = 35
End If
End If
End With
Next cell
End With
End Sub
Numero esempio :
153
Titolo : Visualizzare_le_celle_non_protette
Autore : Søren Remfeldt, mpep
Commento : Mette tutte le celle non protette con un fondo giallo.
Sub CelleNonProtette()
Søren Remfeldt, mpep
lastrw =
Selection.SpecialCells(xlCellTypeLastCell).Row
lastclm =
Selection.SpecialCells(xlCellTypeLastCell).Column
For rowidx = 1 To lastrw
For clmidx = 1 To lastclm
If Cells(rowidx, clmidx).Locked = False Then
Cells(rowidx, clmidx).Interior.ColorIndex = 6
Cells(rowidx, clmidx).Interior.Pattern =
xlSolid
End If
Next
Next
End Sub
Numero
esempio : 154
Titolo : Togliere_apostrofi
Autore : J. Walkenbach, mpep
Commento : Toglie tutti i apostrofi nelle celle
Sub ZapPrefixes()
J. Walkenbach, mpep
For Each cell In ActiveSheet.UsedRange
If cell.PrefixCharacter <> "" Then
cell.Formula = cell.Formula
End If
Next cell
End Sub
Numero esempio :
155
Titolo : Importare_dati_da_un_file_chiuso
Autore :
Commento : Questa macro permette di prendere i dati da un file
chiuso, usando l'ADO.
Dovete aggiungere il referimento : Microsoft ActiveX Data Objects
2.x library
Sub ExportData()
fichDest = "D:OLE_Test.xls"
'Apre l'ADO connezione verso Excel workbook
Set oConn = New ADODB.Connection
oConn.Open "Provider=Microsoft.Jet.OLEDB.4.0;"
& _
"Data Source=" & fichDest & ";" & _
"Extended Properties=""Excel
8.0;HDR=YES;IMEX=2;"""
'Aggiunge i valori per ogni cella
oConn.Execute "Insert into Donnees Values(25)"
'chiude la connezione
oConn.Close
'Apre il workbook per vedere i resultati
DoEvents
Workbooks.Open fichDest
End Sub
' Dovete aggiungere il referimento : Microsoft
ActiveX Data Objects 2.x library
' Inserire dati con ADO
Public Sub WorksheetInsert()
Dim objConn As ADODB.Connection
Dim szConnect As String
Dim szSQL As String
' Creare il testo di connezione.
' szConnect =
"Provider=Microsoft.Jet.OLEDB.4.0;" & _
' "Data Source=C:FilesSales.xls;" & _
' "Extended Properties=Excel 8.0;"
szConnect =
"Provider=Microsoft.Jet.OLEDB.4.0;" & _
"Data Source=D:OLE_Test.xls;" & _
"Extended Properties=Excel 8.0;"
' Creare il SQL stato.
' szSQL = "INSERT INTO " & _
' "VALUES('Val1', 'Val2', Val3, Val4);"
szSQL = "INSERT INTO Donnees " & _
"VALUES('Val1');"
','Val2',28,35,25,1,2,3,4,5);"
' Creare e aprire il Connection object.
Set objConn = New ADODB.Connection
objConn.Open szConnect
' Inserire i dati.
objConn.Execute szSQL, , adCmdText Or
adExecuteNoRecords
' chiudere il Connection object.
objConn.Close
Set objConn = Nothing
Workbooks.Open "d:OLE_Test.xls"
End Sub
' dovete cambiare la configurazione secondo
vostri bisogni
Numero esempio :
156
Titolo : Importare_dati_da_due_file_chiusi
Autore : fs, mpfe
Commento : Se avete diverse file con la stessa impostazione, potete
usare questa macro per importare i dati senza aprire ogni file
usando ADO.
Dovete aggiungere il riferimento
Microsoft ActiveX Data Object 2.x Library
Sub TestConso()
Dim Fich1$, Fich2$, Source1$, Source2$, Cible$
Fich1 = "D:Fichier1.xls"
Fich2 = "D:Fichier2.xls"
Source1 = "Feuil1"
Source2 = "Feuil1"
Cible = "Feuil1"
ConsoDatas Fich1, Source1, Cible
ConsoDatas Fich2, Source1, Cible
End Sub
Public Sub ConsoDatas(NomFichier$,
FeuilleSource$, FeuilleCible$)
'cerca nel workbook NomFichier (senza aprirlo)
i dati
'del foglio FeuilleSource e copia nel foglio
FeuilleCible
'del workbook attivo, dopo i dati (se ci
sono).
'(La riga "testa" da FeuilleSource non è
presa)
'Rob Bovey, mpep
'dovete usare il riferimento
'Microsoft ActiveX Data Object 2.x Library
Dim rsData As ADODB.Recordset
Dim szConnect As String
Dim szSQL As String
Dim Li&, FeuilleDest
''' Crea la connezione
szConnect =
"Provider=Microsoft.Jet.OLEDB.4.0;" & _
"Data Source=" & NomFichier & ";" & _
"Extended Properties=Excel 8.0;"
' la richiesta è basata sul nome del foglio.
questo nome
' deve terminare per un "$" e deve essere
circondato da [].
szSQL = "SELECT * FROM [" & FeuilleSource &
"$];"
Set rsData = New ADODB.Recordset
rsData.Open szSQL, szConnect,
adOpenForwardOnly, _
adLockReadOnly, adCmdText
'dove spedire i dati :
Set FeuilleDest =
ActiveWorkbook.Sheets(FeuilleCible)
Li = FeuilleDest.Range("A65536").End(xlUp).Row
+ 1
'cerca la prima riga vuota
If Not rsData.EOF Then
FeuilleDest.Range("A" & Li).CopyFromRecordset
rsData
Else
'se non ci sono dati...
MsgBox "Nessuno dato trovato.", vbCritical
End If
''' chiude la connezione...
rsData.Close
Set rsData = Nothing
End Sub
Numero esempio :
157
Titolo : Sapere_il_valore_di_una_cella_da_un_file_chiuso
Autore :
Commento : Legge il valore in un file senza aprirlo, usando l'ADO.
Sub test()
Dim fich$, feuil$, Cell As Range
fich = "D:TestADO.xls"
feuil = "feuil1"
Set Cell = Range("A1")
MsgBox GetValueWithADO(fich, feuil, Cell)
End Sub
'questa funzione può essere usata in un foglio
di calcolo
'Ex :
'
=GetValueWithADO("D:TestADO.xls";"feuil1";A1)
Function GetValueWithADO(Classeur$, Feuille$,
Cell As Range)
'Da il valore della cella del foglio "Feuille"
'del workbook chiuso "Classeur"
Dim RcdSet As Object
Dim strConn As String
Dim strCmd As String
Dim dummyBase As Range
'Fa una "database" temporale per la funzione
SELECT
Set dummyBase = Cell.Resize(2)
'configura i commandi ADO e SQL
strConn = "Provider=Microsoft.Jet.OLEDB.4.0;"
& _
"Data Source=" & Classeur & ";" & _
"Extended Properties=""Excel
8.0;HDR=No;IMEX=1;"";"
strCmd = "SELECT * FROM [" & Feuille & "$" &
dummyBase.Address(0, 0) & "]"
'creare l'objet Recordset
Set RcdSet = CreateObject("ADODB.Recordset")
'cercare l'informazione
RcdSet.Open strCmd, strConn, 0, 1, 1
'adOpenForwardOnly, adLockReadOnly, adCmdText
'da l'informazione
GetValueWithADO = Application.Clean(RcdSet(0))
'altra possibilità
' GetValueWithADO
=Application.Clean(RcdSet.GetString(NumRows:=1))
'chiude l'object Recordset
Set RcdSet = Nothing
End Function 'fs
Numero esempio :
158
Titolo : Sapere_i_valori_di_una_zona_di_celle_da_un_file_chiuso
Autore :
Commento : Permette di dare tutti i valori di una zona in un file
chiuso, usando ADO.
Dovete aggiungere il riferimento
Microsoft ActiveX Data Objects 2.x Library
Sub test()
Dim fich$, feuil$, cellAdr$
fich = "D:TestADO.xls"
feuil = "feuilleTest"
cellAdr = "A23"
MsgBox GetValueWithADO(fich, feuil, cellAdr)
Range("C1").Value = GetValueWithADO(fich,
feuil, cellAdr)
End Sub
'Può essere usate in un foglio Excel
'Ex :
'A1 -> "D:TestADO.xls"
'A2 -> "feuilleTest"
'A3 -> "A23"
'A4 -> =GetValueWithADO(A1;A2;A3)
Function GetValueWithADO(Classeur$, Feuille$,
CellAdresse$)
'Da il valore di una cella in un workbook
chiuso
'Dovete aggiungere il referimento
'Microsoft ActiveX Data Objects 2.x Library
Dim rcdSet As New ADODB.Recordset
Dim strConn As String
Dim strCmd As String
Dim dummyBase As Range, Arr
'Crea una "database" temporale per la funzione
SELECT
Set dummyBase = Range(CellAdresse).Resize(2)
'configura i commandi ADO
strConn = "Provider=Microsoft.Jet.OLEDB.4.0;"
& _
"Data Source=" & Classeur & ";" & _
"Extended Properties=""Excel
8.0;HDR=No;IMEX=1;"";"
strCmd = "SELECT * FROM [" & Feuille & "$" &
dummyBase.Address(0, 0) & "]"
'cerca l'informazione
rcdSet.Open strCmd, strConn,
adOpenForwardOnly, adLockReadOnly, adCmdText
'da l'informazione
GetValueWithADO =
Application.Clean(rcdSet.GetString(NumRows:=1))
'altra possibilità
' Arr = rcdSet.GetRows(1)
' If IsNull(Arr(0, 0)) Then
' GetValueWithADO = ""
' Else
' GetValueWithADO = Arr(0, 0)
' End If
End Function 'fs
'Public Sub QueryWorksheet()
'
' Dim rsData As ADODB.Recordset
' Dim szConnect As String
' Dim szSQL As String
'
' ' creare i parametri di connezione
' szConnect =
"Provider=Microsoft.Jet.OLEDB.4.0;" & _
' "Data Source=D:TestADO.xls;" & _
' "Extended Properties=""Excel 8.0;HDR=No"";"
'
' ' Query basato sul foglio "name".
' szSQL = "SELECT *
FROM [feuilleTest$A20:A21]"
' ' Query based on a sheet-level range name.
' 'szSQL = "SELECT * FROM
[Sales$SheetLevelName]"
' ' Query based on a specific range address.
' 'szSQL = "SELECT * FROM [Sales$A1:E89]"
' ' Query based on a book-level range name.
' ' szSQL = "SELECT * FROM BookLevelName"
'
' Set rsData = New ADODB.Recordset
' rsData.Open szSQL, szConnect,
adOpenForwardOnly, _
' adLockReadOnly, adCmdText
'
' ' Verfifica per vedere se ci sono i dati.
' If Not rsData.EOF Then
' Sheet2.Range("A1").CopyFromRecordset rsData
' Else
' MsgBox "Nessuno dato.", vbCritical
' End If
'
' ' Chiude Recordset object.
' rsData.Close
' Set rsData = Nothing
'
'End Sub
'
'
'Public Sub WorksheetInsert()
'
' Dim objConn As ADODB.Connection
' Dim szConnect As String
' Dim szSQL As String
'
' ' Creare i parametri di connezione.
' szConnect =
"Provider=Microsoft.Jet.OLEDB.4.0;" & _
' "Data Source=C:FilesSales.xls;" & _
' "Extended Properties=Excel 8.0;"
'
' ' Creare il SQL statuto.
' szSQL = "INSERT INTO [Sales$] " & _
' "VALUES('VA', 'On-Line', 'Computers', 'Mid',
30)"
'
' ' creare e aprire il Connection object.
' Set objConn = New ADODB.Connection
' objConn.Open szConnect
'
' ' Esecuta il insert statement.
' objConn.Execute szSQL, , adCmdText Or
adExecuteNoRecords
'
' ' chiude il Connection object.
' objConn.Close
' Set objConn = Nothing
'
'End Sub
'
'
'Public Sub QueryTextFile()
'
' Dim rsData As ADODB.Recordset
' Dim szConnect As String
' Dim szSQL As String
'
' ' creare i parametri di connezione.
' szConnect =
"Provider=Microsoft.Jet.OLEDB.4.0;" & _
' "Data Source=C:Files;" & _
' "Extended Properties=Text;"
'
' ' Creare il SQL stato.
' szSQL = "SELECT * FROM Sales.csv WHERE
Type='Art';"
'
' Set rsData = New ADODB.Recordset
' rsData.Open szSQL, szConnect,
adOpenForwardOnly, _
' adLockReadOnly, adCmdText
'
' ' verfifica dei dati.
' If Not rsData.EOF Then
' ' Scrive i dati nel foglio "Sheet1"
' Sheet1.Range("A1").CopyFromRecordset rsData
' Else
' MsgBox "Nessuno dato.", vbCritical
' End If
'
' ' Chiude il Recordset object.
' rsData.Close
' Set rsData = Nothing
'
'End Sub
Numero esempio :
159
Titolo :
Sapere_i_valori_di_una_zona_di_celle_collegate_a_un_file_chiuso
Autore : Ron De Bruin, mpep
Commento : Permette di prendere i dati da un file chiuso, usando
ADO.
Sub test()
GetValuesFromAClosedWorkbook "D:",
"TestADO.xls", "Feuil1", "A1:H25"
End Sub
Sub GetValuesFromAClosedWorkbook(fPath As
String, _
fName As String, sName, cellRange As String)
Ron De Bruin, mpep
'il parametro 'cellRange' deve essere
'*una* zona di cella *legata*
With ActiveSheet.Range(cellRange)
.Formula = "='" & fPath & "[" & fName & "]" _
& sName & "'!"
& cellRange
.Value = .Value
End With
End Sub
Numero esempio :
160
Titolo : Sapere_il_valore_di_una_cella_da_un_file_chiuso2
Autore :
Commento : Legge il valore di una cella in un file chiuso usando
ADO.
Dovete
aggiungere il riferimento :
Microsoft ActiveX Data Objects 2.x Library
Sub LitDatas()
Dim Fich$, Arr
Fich = "d:TestAdo.xls" 'à adapter
'prende i dati a partire da l'indirizzo di una
zona di cella
GetExternalData Fich, "Feuil1", "A1:G20",
False, Arr
'prende i dati a partire da un nome o di una
zona di cella ()
' GetExternalData Fich, "", "nomezona", False,
Arr
With ThisWorkbook.Sheets("Feuil1")
.Range("A1", .Cells(UBound(Arr, 1),
UBound(Arr, 2))).Value = Arr
End With
End Sub
'Da i valori di una zona di cella "legata"
(srcRange)
'di un foglio (srcSheet) di un file (srcFile)
chiuso
'in una tabella (outArr)
'Il parametro TTL indica se la zona ha o non
ha una riga d'intestazione
Sub GetExternalData(srcFile As String, _
srcSheet As String, _
srcRange As String, _
TTL As Boolean, _
outArr As Variant)
'Héctor Miguel, mpep
Dim myConn As ADODB.Connection, myCmd As
ADODB.Command
Dim HDR As String, myRS As ADODB.Recordset,
RS_n As Integer, RS_f As Integer
Dim Arr
Set myConn = New ADODB.Connection
If TTL = True Then HDR = "Yes" Else HDR = "No"
myConn.Open
"Provider=Microsoft.Jet.OLEDB.4.0;" & _
"Data Source=" & srcFile & ";" & _
"Extended Properties=""Excel 8.0;" & _
"HDR=" & HDR & ";IMEX=1;"""
Set myCmd = New ADODB.Command
myCmd.ActiveConnection = myConn
If srcSheet = "" _
Then myCmd.CommandText = "SELECT * from `" &
srcRange & "`" _
Else myCmd.CommandText = "SELECT * from `" &
srcSheet & "$" & srcRange & "`"
Set myRS = New ADODB.Recordset
myRS.Open myCmd, , adOpenKeyset,
adLockOptimistic
ReDim Arr(1 To myRS.RecordCount, 1 To
myRS.Fields.Count)
myRS.MoveFirst
Do While Not myRS.EOF
For RS_n = 1 To myRS.RecordCount 'lrighe
For RS_f = 0 To myRS.Fields.Count - 1 'colonne
Arr(RS_n, RS_f + 1) = myRS.Fields(RS_f).Value
Next
myRS.MoveNext
Next
Loop
myConn.Close
Set myRS = Nothing
Set myCmd = Nothing
Set myConn = Nothing
outArr = Arr
End Sub
' 2 - Scrivere in un file chiuso
Sub EcritDatas()
Dim Fich$, cell As Range
Fich = "d:TestAdo.xls" 'da cambiare
'scrive in un file chiuso i valori delle celle
A1:A5 del foglio attivo
For Each cell In
ActiveWorkbook.Sheets("Feuil1").Range("A1:A5")
SetExternalDatas Fich, "Feuil1",
cell.Address(0, 0), cell.Text
Next
'scrive in A6 la data e l'ora dell'operazione
SetExternalDatas Fich, "Feuil1", "A6", "fatto
il " & Now
'Apre il file per vedere il resultato
DoEvents
Workbooks.Open Fich
End Sub
'scrive "DataToWrite" in una cella
"DestCellAdr"
'del foglio "DestFeuille" del file chiuso
"DestFile"
Sub SetExternalDatas(DestFile As String, _
DestFeuille As String, _
DestCellAdr As String, _
DataToWrite As Variant)
Dim oConn As ADODB.Connection
Dim oCmd As ADODB.Command
Dim oRS As ADODB.Recordset
Dim RangeDest
'd'après Rob Bovey, mpep
' Apre una connezione a Excel spreadsheet
Set oConn = New ADODB.Connection
oConn.Open "Provider=Microsoft.Jet.OLEDB.4.0;"
& _
"Data Source=" & DestFile & ";" & _
"Extended Properties=""Excel 8.0;HDR=No;"";"
' Crea un command object e configura
ActiveConnection
Set oCmd = New ADODB.Command
oCmd.ActiveConnection = oConn
' Il SQL statuto seleziona una zona in un
foglio "feuilleTest" worksheet.
'1 seleziona per una cella
RangeDest = DestCellAdr & ":" & DestCellAdr
oCmd.CommandText = "SELECT * from `" &
DestFeuille & "$" & RangeDest & "`"
' Apre un recordset per prendere i dati.
Set oRS = New
ADODB.Recordset
oRS.Open oCmd, , adOpenKeyset,
adLockOptimistic
' Aggiorna l'ultima riga
oRS(0).Value = DataToWrite
oRS.Update
'chiude la connezione
oConn.Close
Set oConn = Nothing
Set oCmd = Nothing
Set oRS = Nothing
End Sub
Numero esempio :
161
Titolo :
Sapere_il_valore_di_una_cella_da_un_file_chiuso_senza_sapere_dove_e_il_file
Autore :
Commento : Permette di cercare un file sul disco fisso e quando è
trovato, importa la cella scelta senza aprirlo, usando ADO.
Declare Function
SearchTreeForFile Lib "IMAGEHLP.DLL" _
(ByVal lpRootPath As String, _
ByVal lpInputName As String, _
ByVal lpOutputName As String) As Long
'Note : puo essere usato in un foglio excel
'Il file deve essere su un disco rigido del
computer
'Ex :
'
=GetValueCheminRelatif("TestADO.xls";"feuil1";A1)
Function GetValueCheminRelatif(Classeur$,
Feuille$, Cell As Range)
'Da il valore della cella "Cell" del foglio
"Feuille"
'del file chiuso "Classeur"
Dim RcdSet As Object
Dim strConn As String
Dim strCmd As String
Dim dummyBase As Range
Dim CheminComplet$
CheminComplet = TrouveFichier(Classeur)
If CheminComplet = "" Then
GetValueCheminRelatif = "#FICHIER
INTROUVABLE!#"
Exit Function
End If
'Crea una "database" usaando la funzione
SELECT
Set dummyBase = Cell.Resize(2)
'configura i controlli ADO e SQL
strConn = "Provider=Microsoft.Jet.OLEDB.4.0;"
& _
"Data Source=" & CheminComplet & ";" & _
"Extended Properties=""Excel
8.0;HDR=No;IMEX=1;"";"
strCmd = "SELECT * FROM [" & Feuille & "$" &
dummyBase.Address(0, 0) & "]"
'crea l'objet Recordset
Set RcdSet = CreateObject("ADODB.Recordset")
'cerca l'informazione
RcdSet.Open strCmd, strConn, 0, 1, 1
'adOpenForwardOnly, adLockReadOnly, adCmdText
'da l'informazione
GetValueCheminRelatif =
Application.Clean(RcdSet(0))
'chiude
Set RcdSet = Nothing
End Function 'fs
'La funzione da il "path" e il nome del file
cercato
'digate il nome sotto la forma
nomFichier.extension
Function TrouveFichier(ByVal Nom As String)
Dim fso As Object, Lecteurs As Object, L As
Object, S$
Set fso =
CreateObject("Scripting.FileSystemObject")
Set Lecteurs = fso.drives
TrouveFichier = ""
'cerca i diversi dischi fissi e cerca il file
For Each L In Lecteurs
If L.DriveType = 2 Then
S = L.driveletter & ":""
If FindFile(S, Nom) <> "" Then
TrouveFichier = FindFile(S, Nom)
Exit For
End If
End If
Next L
End Function 'fs
Public Function FindFile(RootPath As String,
FileName As String) As String
'Karl Moore,
http://www.vbworld.com/files/tip529.html
'cercare un file !!
Dim lNullPos As Long
Dim lResult As Long
Dim sBuffer As String
Const MAX_PATH = 260
On Error GoTo FileFind_Error
'Da il "path" standard (fs)
If RootPath = "" Then RootPath = Left$(CurDir,
3)
'parametra buffer
sBuffer = Space(MAX_PATH * 2)
'Trova il file
lResult = SearchTreeForFile(RootPath,
FileName, sBuffer)
'Trim null, if exists
If lResult Then
lNullPos = InStr(sBuffer, vbNullChar)
If Not lNullPos Then
sBuffer = Left(sBuffer, lNullPos - 1)
End If
'Return filename
FindFile = sBuffer
Else
'Nothing found
FindFile = vbNullString
End If
Exit Function
FileFind_Error:
FindFile = vbNullString
End Function
Numero esempio :
162
Titolo : Concatenare_le _colonne_di_una_zona
Autore : Remi
Commento : Permette di concatenare le colonne, dopo avere
selezionato la zona da concatenare.
Sub concatenare()
colonna = ActiveCell.Column
colonna2 = colona + 1
riga = ActiveCell.Row
numeroriga = Selection.Rows.Count
ultimariga = riga + numeroriga - 1
For i = riga To ultimariga
risultato = Cells(i, colonna).Value & " - " &
Cells(i, colonan2).Value
ActiveCell = risultato
Cells(i, colonna2).Value = ""
Cells(i + 1, colonna).Select
Next
End Sub
Numero esempio :
163
Titolo :
Cambiare_il_fondo_della_cella_attiva_se_il_foglio_e_protetto
Autore : Remi
Commento : Permette di cambiare il fondo della cella attiva, se il
foglio è protetto.
Private Sub
Worksheet_SelectionChange(ByVal Target As Range)
ActiveSheet.Unprotect
If ActiveCell.Locked = True Then
ActiveCell.Interior.ColorIndex = 6
End If
ActiveSheet.Protect
End Sub
Numero esempio :
164
Titolo : Trovare_le_dieci_prime_lettere_del_nome_del_file
Autore : Remi
Commento : Da le dieci prime lettere del nome del file aperto.
Sub nomeridotto()
nome = ActiveWorkbook.Name
nome2 = Left(nome, 10)
MsgBox (nome2)
End Sub
Numero esempio :
165
Titolo : Aggiungere_=_a_una_zona_di_cella
Autore : Remi
Commento : Crea una formula sulla colonna di destra della zona
attiva, usando il testo ed aggiungendo "=".
Sub somma()
Dim cella As Range
For Each cella In Selection.Cells
valore = cella.Offset(0, -1)
cella.Value = "=" & valore
Next cella
End Sub
Numero esempio :
166
Titolo : Foglio_prima/seguente
Autore : Mauro Gamberini
Commento : Da il nome del foglio di prima o del foglio seguente.
Sub foglioseguente()
ActiveSheet.Next.Select
End Sub
Sub foglioprima()
ActiveSheet.Previous.Select
End Sub
Numero esempio :
167
Titolo : Aggiungere_nomminare_foglio
Autore : Denis Michon, mpfe
Commento : Permette di aggiungere un foglio, creando un nome. La
macro cerca se il nome non è gia stato usato e se è corretto per
Excel.
Attribute VB_Name =
"AggiungereNomminareFoglio"
aggiungere un foglio, dare un nome
' e verificare in nome
Denis Michon, mpfe
Sub NouvelleFeuille()
Dim Sh As Worksheet
Dim Reponse As String
Dim MonNom As String
Dim BonNom As Boolean
Dim LeString
LeString = ":/?*[]"
Do
BonNom = True
Reponse = InputBox("Qual è il nome per" _
+ vbCrLf + "il foglio ?", _
"dare nome ", MonNom)
If Reponse <> "" Then
'verifica se il nome non esiste...
For a = 1 To
ActiveWorkbook.Worksheets.Count
If UCase(Reponse) = UCase(Worksheets(a).Name)
Then
supp = MsgBox( _
"Un foglio con questo nome è già presente," _
+ vbCrLf + vbCrLf + _
"volete sostituirlo ?.", vbYesNo + vbOKOnly, _
"Nome già usato")
If supp = vbYes Then
Application.DisplayAlerts = False
Worksheets(Reponse).Delete
Application.DisplayAlerts = True
Exit For
Else
BonNom = False
MonNom = Reponse
Exit For
End If
End If
Next
'verifica che il nome non fa più di 31
caratteri...
If Len(Reponse) > 31 Then
MsgBox "Il numero di carattere (" & _
Len(Reponse) & ") del nome è troppo grande" _
+ vbCrLf + " il massimo è (31) per excel.", _
vbCritical + vbInformation, "Nome troppo
longo"
BonNom = False
MonNom = Reponse
End If
'verifica se nel nome non ci sono caratteri
vietati...
For a = 1 To
Len(LeString)
If InStr(1, Reponse, Mid(LeString, a, 1),
vbTextCompare) > 0 Then
MsgBox "I caratteri seguenti : " & _
LeString & " sono vietati" _
+ vbCrLf + "nel nome del foglio.", _
vbCritical + vbOKOnly, "carattere vietato"
BonNom = False
MonNom = Reponse
Exit For
End If
Next
Else
Exit Sub
End If
Loop Until BonNom = True
Set Sh =
Worksheets.Add(after:=Worksheets(Worksheets.Count))
Sh.Name = Reponse
End Sub
Numero esempio :
168
Titolo : distruggere_file
Autore : Chip Pearson & Bob Umlas, mpep
Commento : Attenzione, questa macro distrugge il file per sempre !!!
Dovete scrivere la macro nell'evento BeforeClose del workbook, o
usando la funzione Ontime.
Sub Distruzione()
Dim FName As String
Dim Ndx As Integer
With ThisWorkbook
.Save
For Ndx = 1 To Application.RecentFiles .Count
If Application.RecentFiles(Ndx).Path =
.FullName Then
Application.RecentFiles(Ndx).Delete
Exit For
End If
Next Ndx
.ChangeFileAccess Mode:=xlReadOnly
Kill .FullName
.Close SaveChanges:=False
End With
End Sub
Numero esempio :
169
Titolo : data_e_l'ora_della_creazione_del_file
Autore : papou, mpfe
Commento : Pemette di scrivere in una cella, le diverse proprietà di
un file.
Sub test()
Range("A8").Value = _
Format(ActiveWorkbook.BuiltinDocumentProperties("Crea tion Date"), _
"MM/DD/YY hh: mm ")
End Sub
'vedere in una cella la data e l'ora della
modifica del documento ?
Sub
DateHeureModifClasseur()
'...Patrick, mpfe
Sheets(1).Range("A1") =
FileDateTime(ThisWorkbook.FullN ame)
End Sub
'(FileDateTime è preciso alla secondo)
'o :
Sub test22()
'preciso al minuto
Range("A2").Value = _
Format(ActiveWorkbook.BuiltinDocumentProperties("Last sav e time"),
_
"MM/DD/YY hh: mm ")
End Sub
'Da le proprietà del documento
'BuiltinDocumentProperties :
Sub PropriétésDoc()
'codice Microsoft (Xl 2000)
rw = 1
Worksheets.Add
On Error Resume Next
For Each p In
ActiveWorkbook.BuiltinDocumentProperties
Cells(rw, 1).Value = p.Name
Cells(rw, 2).Value = p.Type
Cells(rw, 3).Value = p.Value
rw = rw + 1
Next
End Sub
Numero esempio :
170
Titolo : calendario1900_1904
Autore : mpfe Thomas Corvaisier
Commento : Permette di usare il calendario 1900 al posto del
calendario 1904.
Sub
Cambia_Calendario_ma_tiene_Date()
mpfe Thomas Corvaisier
Const Répertoire As String = "C:temp""
'cambiare ...
Dim I As Integer
Dim Feuille As Worksheet
Dim Cellule As Range, Plage As Range
With Application
.ScreenUpdating = False
.Calculation = xlCalculationManual
End With
With Application.FileSearch
.NewSearch
.LookIn = Répertoire
.FileType = msoFileTypeExcelWorkbooks
.SearchSubFolders = False
If .Execute(SortBy:=msoSortByFileName, _
SortOrder:=msoSortOrderAscending) > 0 Then
For I = 1 To .FoundFiles.Count
Workbooks.Open Filename:=.FoundFile s( I), _
UpdateLinks:=False,
IgnoreReadOnlyRecommended:=True
With ActiveWorkbook
.Date1904 = False
For Each Feuille In .Worksheets
On Error Resume Next
Set Plage = _
Feuille.UsedRange.SpecialCells(xlCe ll
TypeConstants)
On Error GoTo 0
If Not (Plage Is Nothing) Then
For Each Cellule In Plage
If IsDate(Cellule) Th en _
Cellule.Value = Cellule.Val ue 1462
Next Cellule
Set Plage = Nothing
End If
Next Feuille
.Close True
End With
Next I
Else
MsgBox "Alcune file trovato."
End If
MsgBox .FoundFiles.Count & " file modificat i.
"
End With
With Application
.ScreenUpdating = True
.Calculation = xlCalculationAutomatic
End With
End Sub
Numero esempio :
171
Titolo : scambia_un_carattere_vietato_con_il_carattere_"_"
Autore : leo.heuser@get2net.dk
Commento : Questa funzione cambia i caratteri vietati per il nome
del file, con il carattere "_".
Function
ReplaceIllegalChars(fileName As String) As String
leo.heuser@get2net.dk
Dim illegal As Variant
Dim 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
Numero esempio :
172
Titolo : cambiare_i_collegamenti_in_un_file
Autore : L Longre, mpfe
Commento : Peremette di maniera automatica, di cambiare i
collgamenti comuni.
Sub
CambiareCollegamenti()
L Longre, mpfe
Dim Liaison, partenza$, arrivata$
partenza = "c:temptruc1.xls"'<-- a cambiare
arrivata = "C:TempTruc2.xls" '<-- a cambiare
For Each Liaison In
ActiveWorkbook.LinkSources(xlExcelLinks)
If LCase$(Liaison) = partenza Then Exit For
Next
If Not IsEmpty(Liaison) Then _
ActiveWorkbook.ChangeLink Liaison, arrivata
End Sub
Numero esempio :
173
Titolo : cambiare_la_zone_di_dati_di_una_tabella_pivot
Autore : Bill Manville, mpep
Commento : Cambia la zona di una tabella Pivot.
Sub
ChangePivotSources()
Bill Manville, mpep
Dim stFrom As String
Dim stTo As String
Dim stFromDB As String
Dim stToDB As String
Dim stConn As String
Dim stSQL As String
Dim PC As PivotCache
Dim WS As Worksheet
Dim PT As PivotTable
Dim V
' change all pivot caches from using path
stFrom to stTo
' and from using "Test.MDB" to using
"Real.MDB"
stFrom = "P:""
stTo = "G:Data""
stFromDB = "Test.mdb"
stToDB = "Real.mdb"
For Each PC In ActiveWorkbook.PivotCaches
stConn = PC.Connection
stConn = Subst(stConn, stFrom, stTo)
stConn = Subst(stConn, stFromDB, stToDB)
PC.Connection = SplitToArray(stConn, 255)
stSQL = PC.Sql
stSQL = Subst(stSQL, stFrom, stTo)
stSQL = Subst(stSQL, stFromDB, stToDB)
PC.Sql = SplitToArray(stSQL, 255)
Next
' refresh all pivot tables
For Each WS In ActiveWorkbook.Worksheets
For Each PT In WS.PivotTables
PT.RefreshTable
Next
Next
End Sub
Function Subst(ByVal InString As String,
stReplace As String, stWith As String) As String
' replace any occurrence of stReplace in
InString with stWith
Dim stResult As String
Dim iChar As String
iChar = InStr(LCase(InString),
LCase(stReplace)) ' string compare is Case sensitive
Do While iChar > 0
stResult = stResult & Left(InString, iChar -
1) & stWith
InString = Mid(InString, iChar +
Len(stReplace))
iChar = InStr(LCase(InString),
LCase(stReplace))
Loop
Subst = stResult & InString
End Function
Function SplitToArray(ST As String, Lump As
Integer)
' break a long string up into an array with
each element of size Lump
' don't bother if string is not longer than
Lump
Dim A()
Dim I As Integer
If Len(ST) <= Lump Then
SplitToArray = ST
Else
ReDim A(1 To Len(ST) Lump + 1)
For I = 1 To Len(ST) Lump + 1
A(I) = Mid(ST, 1 + (I - 1) * Lump, Lump)
Next
SplitToArray = A()
End If
End Function
Numero esempio :
174
Titolo : Ricerca_i_collegamenti_in_un_file
Autore : Jean-Pierre Pastinelli, mpfe
Commento : Ricerca tutti i collegamenti in un file.
Sub
CercaCollegamenti()
'
Dim LIAISRECH As String
On Error Resume Next
nbf = ActiveWorkbook.Sheets.Count
z = Err
On Error GoTo 0
If z <> 0 Then Exit Sub
LIAISRECH = InputBox("Indicate un pezzo del
collegamento ricercato...", _
"UTILITAIRE JPP")
If LIAISRECH = "" Then Exit Sub
Debug.Print "Inizia l'analisi (Collegamento
specifico con """ & _
LIAISRECH & """) del file : ",
ActiveWorkbook.Name, _
"(", Trim(Str(nbf)), " fogli)"
For isheet = 1 To nbf
Sheets(isheet).Select
Debug.Print ActiveSheet.Name
z = ActiveSheet.Type
If z = -4169 Then GoTo FIN 'GRAPHICO
If z <> -4167 Then GoTo FIN 'NUMERI
ActiveCell.SpecialCells(xlLastCell).Select
Range("A1", Selection).Select
On Error Resume Next
X1 = 0
Y1 = 0
boucle:
Selection.Find(What:="=", After:=ActiveCell,
LookIn:=xlFormulas, LookAt _
:=xlPart, SearchOrder:=xlByRows,
SearchDirection:=xlNext, MatchCase:= _
False).Activate
zz = Err
If (zz <> 91) Then
X2 = ActiveCell.Column
Y2 = ActiveCell.Row
If (Y2 < Y1) Or ((Y2 = Y1) And (X2 < X1)) Or
((Y2 = Y1) And (X2 = X1)) Then GoTo finboucle
WW = ActiveCell.Formula
If InStr(1, WW, LIAISRECH) = 0 Then GoTo suite
Debug.Print zz, ActiveSheet.Name,
ActiveCell.Address, ActiveCell.Formula
suite:
X1 = ActiveCell.Column
Y1 = ActiveCell.Row
GoTo boucle
Else
Debug.Print zz, ActiveSheet.Name
finboucle:
On Error GoTo 0
End If
FIN:
Next isheet
Debug.Print "Fine di analisi (Collegamento
specifico con """ & _
LIAISRECH & """) del file : ",
ActiveWorkbook.Name
End Sub
Numero esempio :
175
Titolo : Scegliere_un_foglio_con_un_inputbox
Autore : Rene Roy, mpfe
Commento : Permette di scegliere il foglio nel file attivo, con
l'aiuto di una inputbox che fa visualizzare tutti i fogli.
Sub AccesSection()
Dim i As Integer
Dim TopPos As Integer
Dim SheetCount As Integer
Dim PrintDlg As DialogSheet
Dim CurrentSheet, FeuilleDépart As Worksheet
Dim cb As OptionButton
Application.ScreenUpdating = False
' aggiunge un foglio temporaneo
Set CurrentSheet = ActiveSheet
Set FeuilleDépart = ActiveSheet
Set PrintDlg = ActiveWorkbook.DialogSheets.Add
PrintDlg.Visible = xlSheetHidden
SheetCount = 0
' aggiunge i pulsanti di opzione
TopPos = 40
For i = 1 To ActiveWorkbook.Worksheets.Count
Set CurrentSheet =
ActiveWorkbook.Worksheets(i)
' Non vede i fogli nascosti
If Application.CountA(CurrentSheet.Cells) <> 0
And _
CurrentSheet.Visible Then
SheetCount = SheetCount + 1
PrintDlg.OptionButtons.Add 78, TopPos, 150,
16.5
PrintDlg.OptionButtons(SheetCount).Text = _
CurrentSheet.Name
If CurrentSheet.Name = FeuilleDépart.Name Then
_
PrintDlg.OptionButtons(SheetCount).Value =
xlOn
TopPos = TopPos + 13
End If
Next i
' mette i pulsanti OK e Cancela
PrintDlg.Buttons.Left = 240
' Mette l'inputbox al formato ideale
With PrintDlg.DialogFrame
.Height = Application.Max _
(68, PrintDlg.DialogFrame.Top + TopPos - 34)
.Width = 230
.Caption = "Qual è il foglio scelto ? "
End With
' Cambia l'ordine del focus dei pulsanti
PrintDlg.Buttons("Button 2").BringToFront
PrintDlg.Buttons("Button 3").BringToFront
' visualizza l'inputbox
FeuilleDépart.Activate
Application.ScreenUpdating = True
If SheetCount <> 0 Then
If PrintDlg.Show Then
Application.ScreenUpdating = False
For i = 1 To SheetCount
If PrintDlg.OptionButtons(i).Value = xlOn Then
Worksheets(PrintDlg.OptionButtons(i).Caption).Activate
'altro codice se bisogno
End If
Next i
End If
Else
MsgBox "Tutti i fogli sono vuoti."
End If
' cancella l'inputbox
Application.DisplayAlerts = False
PrintDlg.Delete
End Sub
Numero esempio :
176
Titolo : Sapere_se_un_file_e_aperto_o_non
Autore :
Commento : Permette di sapere se un file è aperto o non.
Sub Fileaperto()
Dim Chemin$, Wbk As Workbook
Chemin = "D:
Numero esempio :
177
Titolo : prova_se_un_file_condiviso_sulla_rete_e_aperto_o_non
Autore : Microsoft
Commento : Permette di sapere se un file condiviso sulla rete è
aperto o non. PErmette di togliere il messaggio d'Excel "Lettura
sola o notifica ?"
Function
IsFileOpen(filename As String)
(codice Microsoft :
http://support.microsoft.com/default.aspx?scid=kb;EN-US;q138621)
Dim filenum As Integer, errnum As Integer
On Error Resume Next ' Turn error checking
off.
filenum = FreeFile() ' Get a free file number.
' Attempt to open the file and lock it.
Open filename For Input Lock Read As #filenum
Close filenum ' Close the file.
errnum = Err ' Save the error number that
occurred.
On Error GoTo 0 ' Turn error checking back on.
' Check to see which error occurred.
Select Case errnum
' No error occurred.
' File is NOT already open by another user.
Case 0
IsFileOpen = False
' Error number for "Permission Denied."
' File is already opened by another user.
Case 70
IsFileOpen = True
' Another error occurred, file is being
queried.
Case Else
Error errnum
End Select
End Function
Numero
esempio : 178
Titolo : Paragonare_due_fogli
Autore : fs
Commento : Crea una tabella con l'indirizzo delle celle del foglio
A, scrive i valori di queste celle ed anche del foglio2
Sub
ParagonareDueFogli()
Dim Arr, i%
Arr = ComparerDeuxFeuilles(Sheets("Feuil1"),
Sheets("Feuil2"))
Sheets.Add
For i = LBound(Arr, 1) To UBound(Arr, 2)
Cells(i, 1).Value = Arr(i, 1)
Cells(i, 2).Value = Arr(i, 2)
Cells(i, 3).Value = Arr(i, 3)
Next i
End Sub
Function ComparerDeuxFeuilles(Feuille1 As
Worksheet, feuille2 As Worksheet)
Dim Differences1() ' Contienne l'inidrizzo
delle celle
Dim differences2() ' contienne i valori del
foglio1
Dim differences3() ' contienne i valori del
foglio2
Dim Differences() ' crea una tabella unical
Dim Compteur As Long, Compteur2 As Long
Dim Plage1 As Range
Dim Cellule As Range
Dim DeuxiemeFeuille As Worksheet
Compteur = 1
' prende i dati da A1 a l'ultima cella
If
Application.WorksheetFunction.Count(Feuille1.Cells()) > _
Application.WorksheetFunction.Count(feuille2.Cells()) Then
Set Plage1 =
Range(Feuille1.Range("a1").Address, _
Feuille1.Range("a1").SpecialCells(xlCellTypeLastCell).Address)
DeuxiemeFeuille = feuille2
Else
Set Plage1 =
Range(feuille2.Range("a1").Address, _
feuille2.Range("a1").SpecialCells(xlCellTypeLastCell).Address)
Set DeuxiemeFeuille = Feuille1
End If
' Paragona il foglio1 e foglio2
For Each Cellule In Plage1
If Cellule <>
DeuxiemeFeuille.Range(Cellule.Address) Then
' Se diverso fa la tabella
ReDim Preserve Differences1(Compteur)
ReDim Preserve differences2(Compteur)
ReDim Preserve differences3(Compteur)
Differences1(Compteur) = Cellule.Address
differences2(Compteur) =
Feuille1.Range(Cellule.Address)
differences3(Compteur) =
feuille2.Range(Cellule.Address)
Compteur = Compteur + 1
End If
Next Cellule
' crea la tabella
Compteur = Compteur - 1
' Se tutti i dati sono identici = TRUE
If Compteur = 0 Then
ComparerDeuxFeuilles = True
Exit Function
End If
ReDim Differences(1 To Compteur, 1 To 3)
For Compteur2 = 1 To Compteur
' Digita la tabella
Differences(Compteur2, 1) =
Differences1(Compteur2)
Differences(Compteur2, 2) =
differences2(Compteur2)
Differences(Compteur2, 3) =
differences3(Compteur2)
Next Compteur2
ComparerDeuxFeuilles = Differences
End Function
Numero esempio :
179
Titolo : Paragonare_contenuto_file
Autore : Pierre Fauconnier, mpfe
Commento : Due macro : paragona e paragona1
'paragona ogni riga del elenco1 con ogni celle nell'elenco2 e mette
la cella elenco1 in rosso se non a trovato un valore identica
nell'elenco2
'paragona1 non usa degli elenci, invece usa le colonne.
Sub Comparaison()
Application.ScreenUpdating = False
Dim Cellule1 As Range, Cellule2 As Range
Dim Time1 As Date, Time2 As Date
Time1 = Now()
Workbooks("classeur1.xls").Activate
For Each Cellule1 In Range("liste1")
Workbooks("classeur2.xls").Activate
For Each Cellule2 In Range("liste2")
If Cellule1 <> Cellule2 Then
Cellule1.Font.Color = vbRed
Else
Cellule1.Font.Color = vbBlack
Exit For
End If
Next Cellule2
Workbooks("classeur1.xls").Activate
Next Cellule1
Time2 = Now()
Debug.Print "TestListe :" & Format$(Time2 -
Time1, "hh:mm:ss")
Application.ScreenUpdating = True
End Sub
Sub Comparaison1()
Application.ScreenUpdating = False
Dim Collection1 As New Collection, collection2
As New Collection
Dim Cellule1 As Range, Cellule2 As Range
Dim Element1 As Object, Element2 As Object
Dim Time1 As Date, Time2 As Date
Time1 = Now()
Workbooks("classeur1.xls").Activate
For Each Cellule1 In Range("a:a")
Collection1.Add Cellule1
Next Cellule1
Workbooks("classeur2.xls").Activate
For Each Cellule2 In Range("a:a")
collection2.Add Cellule2
Next Cellule2
For Each Element1 In Collection1
For Each Element2 In collection2
If Element1 <> Element2 Then
Element1.Font.Color = vbRed
Else
Element1.Font.Color = vbBlack
Exit For
End If
Next Element2
Next Element1
Time2 = Now()
Debug.Print "Test collection :" &
Format$(Time2 - Time1, "hh:mm:ss")
Application.ScreenUpdating = True
End Sub
Numero esempio :
180
Titolo : Paragonare_due_fogli_2
Autore :
Commento : Permette di paragonare due fogli interi.
Sub test22()
CompareWorksheets Sheets("feuil1"),
Sheets("feuil7")
End Sub
Sub CompareWorksheets(ws1 As Worksheet, ws2 As
Worksheet)
Dim r As Long, c As Integer
Dim lr1 As Long, lr2 As Long, lc1 As Integer,
lc2 As Integer
Dim maxR As Long, maxC As Integer, cf1 As
String, cf2 As String
Dim rptWB As Workbook, DiffCount As Long
Application.ScreenUpdating = False
Application.StatusBar = "Creating the
report..."
Set rptWB = Workbooks.Add
Application.DisplayAlerts = False
While Worksheets.Count > 1
Worksheets(2).Delete
Wend
Application.DisplayAlerts = True
With ws1.UsedRange
lr1 = .Rows.Count
lc1 = .Columns.Count
End With
With ws2.UsedRange
lr2 = .Rows.Count
lc2 = .Columns.Count
End With
maxR = lr1
maxC = lc1
If maxR < lr2 Then maxR = lr2
If maxC < lc2 Then maxC = lc2
DiffCount = 0
For c = 1 To maxC
Application.StatusBar = "Comparing cells " &
Format(c / maxC, "0 %") & "..."
For r = 1 To maxR
cf1 = ""
cf2 = ""
On Error Resume Next
cf1 = ws1.Cells(r, c).FormulaLocal
cf2 = ws2.Cells(r, c).FormulaLocal
On Error GoTo 0
If cf1 <> cf2 Then
DiffCount = DiffCount + 1
Cells(r, c).Formula = "'" & cf1 & " <> " & cf2
End If
Next r
Next c
Application.StatusBar = "Formatting the
report..."
With Range(Cells(1, 1), Cells(maxR, maxC))
.Interior.ColorIndex = 19
With .Borders
.LineStyle = xlContinuous
.Weight = xlHairline
End With
End With
Columns("A:IV").ColumnWidth = 15
rptWB.Saved = True
If DiffCount = 0 Then
rptWB.Close False
End If
Set rptWB = Nothing
Application.StatusBar = False
Application.ScreenUpdating = True
MsgBox DiffCount & " cells contain different
formulas!", vbInformation, _
"Compare " & ws1.Name & " with " & ws2.Name
End Sub
Numero esempio :
181
Titolo : Contare_il_numero_di_parole_in_un_file
Autore : fs
Commento : Conta il numero delle parole in tutte le cartelle del
dossier scelto.
Public Li&
Sub Contaparole()
Dim Dossier$, wbk As Workbook, derLi&
Dossier = ChoisirDossier 'scegliere la
cartella
'foglio per vedere i risultati
Set wbk = Workbooks.Add
wbk.ActiveSheet.Name = "contaparole"
With wbk.ActiveSheet
Cells(1, 1).Value = "Cartella"
Cells(1, 2).Value = "Numero di parole"
Cells(1, 3).Value = "Somma generale"
With Range("A1:C1,C2")
.HorizontalAlignment = xlCenter
.Interior.ColorIndex = 36
With .Font
.Name = "Arial": .Bold = True: .Size = 11
End With
With .Borders
.LineStyle = xlContinuous: .Weight = xlThick
End With
End With
End With
Li = 1
Application.ScreenUpdating = False
CompteTousLesMots Dossier, wbk
Application.ScreenUpdating = True
derLi = wbk.Sheets(1).UsedRange.Rows.Count
wbk.Sheets(1).Cells(2, 3).FormulaLocal =
"=Somme(B2:B" & derLi & ")"
wbk.Sheets(1).Columns("A:C").AutoFit
End Sub
Sub CompteTousLesMots(LeDossier$, Classeur As
Workbook)
Dim fso As Object, Dossier As Object, sousRep
As Object, fich As Object
Dim sht As Worksheet, Compteur&
'Static Li&
Set fso =
CreateObject("Scripting.FileSystemObject")
Set Dossier = fso.GetFolder(LeDossier)
'esamina la cartella
For Each fich In Dossier.Files
If UCase(fso.GetExtensionName(fich.Name)) =
"XLS" Then
Compteur = 0: Li = Li + 1
Classeur.Sheets(1).Range("A" & Li).Value =
fich.Path
Workbooks.Open Filename:=fich.Path,
UpdateLinks:=0
For Each sht In ActiveWorkbook.Sheets
sht.Activate
'conta parole per foglio
Compteur = Compteur +
CompteMots(sht.UsedRange)
Next
ActiveWorkbook.Close False
Classeur.Sheets(1).Range("B" & Li).Value =
Compteur
End If
Next
'guarda i sotto dossier
For Each sousRep In Dossier.SubFolders
CompteTousLesMots sousRep.Path, Classeur
Next sousRep
Set fso = Nothing
End Sub
Function CompteMots(Plage As Range) As Long
Dim Cell As Range
For Each Cell In Plage
'cancella le celle con un numero o una data
If Not IsNumeric(Cell.Value2) Then
CompteMots = CompteMots +
UBound(Split(Cell.Text, " ")) + 1
End If
Next
End Function
Function ChoisirDossier()
Dim objShell, objFolder, chemin, SecuriteSlash
Set objShell =
CreateObject("Shell.Application")
Set objFolder = _
objShell.BrowseForFolder(&H0&, "Scegliete un
repertorio", &H1&)
On Error Resume Next
chemin =
objFolder.ParentFolder.ParseName(objFolder.Title).Path & ""
If objFolder.Title = "Bureau" Then
chemin = "C:WindowsBureau"
End If
If objFolder.Title = "" Then
chemin = ""
End If
SecuriteSlash = InStr(objFolder.Title, ":")
If SecuriteSlash > 0 Then
chemin = Mid(objFolder.Title, SecuriteSlash -
1, 2) & ""
End If
ChoisirDossier = chemin
End Function
Numero esempio :
182
Titolo : Copiare_un_foglio_cambiando_formule_per_valori
Autore : fs
Commento : Questa macro copia un foglio, cambiando tutte le formule
con i valori (= Incolla speciale => Valori).
Sub
CopieFeuilleValeursSeules()
With ActiveSheet
.Copy
.UsedRange.Cells.Value =
(.UsedRange.Cells.Value)
.Range("A1").Select
End With
End Sub 'fs
Numero esempio :
183
Titolo : Copiare_salvare_file_backup
Autore : Joël MAU, mpfe
Commento : Questa macro crea un dossier "SALVATAGGIO" (potete
cambiarlo con la constante : DossierSauvegarde) su vostro disci
fisso, ed all'apertura del foglio "foglio1" (potete cambiarlo con la
constante : Const NomFeuilleACopier) , crea un copia e la salva in
questo dossier.
Attribute VB_Name = "CopiaSalvaFoglio"
'salvataggio automatico di un file
(Joël MAU, mpfe)
'quando si apre il foglio "MaFeuille",
'(a modificare con il valore della costante
NomFeuilleACopier)
'e copiato in un nuovo file
'nel ripertorio di salvatagio
'(In standard "SAUVEGARDES"", crea il
ripertorio,
'(modifica il ripertorio con la costante
DossierSauvegarde)
'per tenire tutti i salvataggi, il file e
salvato con il
'nome, giorno e ora
'Per avviare quando il file si apre :
'====dans le module ThisWorkbook :
'Private Sub Workbook_Open()
' SauvegardeFeuille
'End Sub
'==================
'Poi creare un modulo e copiare la macro
'un foglio e creato ogni volta che si apre :
Public Const NomFeuilleACopier As String =
"foglio1"
Public Const DossierSauvegarde As String =
"SALVATAGGIO""
Public Const sFormatDate As String =
"""_""ddmmyy""_""hh""h""mm""mn"""
Sub SauvegardeFeuille()
Dim MaFeuille As Worksheet
Dim sPath As String, sFileSave As String
sPath = ThisWorkbook.Path & """
MsgBox ThisWorkbook.Name & " " &
InfoDateModifFichier(ThisWorkbook.Name)
If FeuilleExiste(NomFeuilleACopier) Then
If Not FichierExiste(sPath &
DossierSauvegarde) Then
' Il ripertorio non esiste
MkDir sPath & DossierSauvegarde
' crea un ripertorio se non esiste
End If
sFileSave = sPath & DossierSauvegarde &
NomFeuilleACopier & _
InfoDateModifFichier(ThisWorkbook.Name) &
".xls"
If Not FichierExiste(sFileSave) Then
' Il file non esiste. Altrimenti non fare
niente
Worksheets(NomFeuilleACopier).Copy
ActiveWorkbook.SaveAs _
Filename:=sFileSave, FileFormat:=xlNormal, _
Password:="", WriteResPassword:="", _
ReadOnlyRecommended:=False,
CreateBackup:=False
ActiveWorkbook.Close SaveChanges:=False
' e gia registrato !
End If
End If
End Sub
Function FeuilleExiste(sName As Variant) As
Boolean
' Prova se il foglio "sName" esiste nella
cartella
' Risponde vero se esiste!
On Error Resume Next
FeuilleExiste = False
FeuilleExiste = Not
ActiveWorkbook.Sheets(sName) Is Nothing
Err.Clear
End Function
Function FichierExiste(sFile As Variant) As
Boolean
' prova se il file con il nome "sFle" esiste o
no.
Dim sProv As String
On Error GoTo Errorhandler
sProv = Dir(sFile, vbDirectory)
' vbDirectory è utile quando il ripertorio è
vuoto perchè risponde con "."
FichierExiste = (sProv <> "")
Exit Function
Errorhandler:
MsgBox prompt:="Errore sulla prova del file= "
& sFile
End
End Function
Function InfoDateModifFichier(ByVal sFileIn As
String) As String
' Manda la data e l'ora di modifica del file ,
'o la data e l'ora di adesso
If FichierExiste(sFileIn) Then
InfoDateModifFichier =
Format(FileDateTime(sFileIn), sFormatDate)
Else
InfoDateModifFichier = Format(Now,
sFormatDate)
'giorno ed ora attuale
End If
End Function
Numero esempio :
184
Titolo : Corregere_Data_1904
Autore :
Commento : Cambiare la data 1904, con la data 1900.
Sub
CorregereData1904()
With ActiveWorkbook
For Each sht In .Sheets
sht.Select
For Each cell In sht.UsedRange
If IsDate(cell.Value) Then
cell.Value = cell.Value - 1462
End If
Next
Next
End With
End Sub
Numero esempio :
185
Titolo : Creare_ripertorio_con_il_nome_dei_fogli
Autore : b.marchand mpfe
Commento : Questa macro permette la creazione di un foglio in cui
sarà scritto tutte le cartelle e tutti i fogli, con dei collegamenti
per facilitare il cambio di foglio.
Sub CreationLiens()
Dim Feuille As Worksheets, n As Integer, L As
Integer
Dim ExisteFeuille As Boolean, wCell As Range,
Réponse As Long
On Error Resume Next
ExisteFeuille = Worksheets("Ripertorio").Name
If Err.Number = 9 Then
Err.Clear
Réponse = _
MsgBox("Dovete avere un foglio chiamato
(Ripertorio) !" & vbCrLf _
& "Volete crearla ?", vbYesNo, _
"Creazione dei collegamenti")
If Réponse = vbNo Then Exit Sub
ActiveWorkbook.Worksheets.Add
before:=Sheets(1)
ActiveSheet.Name = "Ripertorio"
End If
On Error GoTo 0
With Sheets("Ripertorio")
L = 1
.Cells.Clear
For n = 1 To Worksheets.Count
If Worksheets(n).Name <> "Ripertorio" Then
.Activate
.Hyperlinks.Add _
Anchor:=.Cells(L, 1), Address:="", _
SubAddress:="'" & Worksheets(n).Name & "'!A1"
.Cells(L, 1).Value = Worksheets(n).Name
.Cells(L, 1).Select
If Worksheets(n).[A1].Hyperlinks.Count = 1 Or
_
IsEmpty(Worksheets(n).[A1]) Then
Set wCell = Worksheets(n).[A1]
ElseIf Worksheets(n).[B1].Hyperlinks.Count = 1
Or _
IsEmpty(Worksheets(n).[B1]) Then
Set wCell = Worksheets(n).[B1]
ElseIf Worksheets(n).[C1].Hyperlinks.Count = 1
Or _
IsEmpty(Worksheets(n).[C1]) Then
Set wCell = Worksheets(n).[C1]
End If
If Not wCell Is Nothing Then
Worksheets(n).Hyperlinks.Add _
Anchor:=wCell, Address:="", _
SubAddress:="'" &
Worksheets("Ripertorio").Name _
& "'!" & .Cells(L, 1).Address(0, 0)
wCell.Value = "Ritorno al Ripertorio"
End If
L = L + 1
Set wCell = Nothing
End If
Next
End With
End Sub
Numero esempio :
186
Titolo : Creare_sommario_con_il_nome_dei_fogli
Autore : ChrisV, mpfe
Commento : Permette di creare un sommario che visualizza tutti gli
altri fogli della cartella con dei collegamenti ipertestuali.
CreareSommarioFogli()
Application.ScreenUpdating = False
Set nSht = Sheets.Add(Before:=Sheets(1))
On Error GoTo GesErr
DebProc:
nSht.Name = "Sommario"
[A1] = "Elenco dei fogli"
With Selection.Font
.Bold = True
.Size = 12
End With
For i = 2 To Sheets.Count
nSht.Cells(i, 1).Value = Sheets(i).Name
With Worksheets(nSht.Name)
ActiveSheet.Hyperlinks.Add Anchor:= .C ell
s(i, 2), _
Address:="", SubAddress:=Sheets (i ).N ame &
"!A1", _
TextToDisplay:="Lien vers " & Sh eets(i).Name
End With
Next i
With Rows("1:1")
.RowHeight = 40
.VerticalAlignment = xlCenter
End With
[E2].Activate
ActiveWindow.DisplayGridlines = False
Exit Sub
GesErr:
Application.DisplayAlerts = False
Sheets("Sommario").Delete
Application.DisplayAlerts = True
GoTo DebProc
End Sub
Numero esempio :
187
Titolo : Cercare_valore_in_un_file
Autore : Nanant Vasanati, mpep
Commento : Se cercate un valore ma non sapete più in quale file è
messo, questa funzione vi aiuterà. Ricerca in tutte le cartelle
aperte e tutti i fogli.
Function
FindWorkbook(MyString As String) As String
Nanant Vasanati, mpep
Dim wb As Workbook, ws As Worksheet
Dim c As Range, fMatchFound As Boolean
fMatchFound = False
For Each wb In Workbooks
For Each ws In wb.Worksheets
For Each c In ws.UsedRange
If c.Value = MyString Then
fMatchFound = True
Exit For
End If
Next
If fMatchFound Then Exit For
Next
If fMatchFound Then Exit For
Next
If fMatchFound Then
FindWorkbook = wb.Name
Else
MsgBox "Non trovato !"
End If
End Function
Numero esempio :
188
Titolo : Data_di_salvataggio_in_una_cella
Autore : Iznogood, mpfe
Commento : Una funzione per scrivere la data di salvataggio della
cartella e l'ora dell'ultima modifica in una cella.
Function
DateSauvegarde()
Dim path
Application.Volatile
path = Application.ActiveWorkbook.path
If path = "" Then
DateSauvegarde = "File non salvato !"
Else
If Right(path, 1) <> """ Then path = path &
"""
DateSauvegarde = FileDateTime(path &
ActiveWorkbook.Name)
End If
End Function
'et en B9 :
'=DateSauvegarde()
'(senza dimenticare B9 con il formato data)
Numero esempio :
189
Titolo : Fare_il_contrario_di_una_tabella_pivot
Autore : Daniel Maher
Commento : Persentare una tabella pivot, come un elenco.
Sub test()
Decrois e Range("A1:F5"), Rang e("H1")
End Sub
Sub Decrois e(ByVal RInput As Range, ROutpu t
As Range)
Dim i A s Integer, j As Intege r, k As I
nteger
k = 1
For i = 2 To RInput.Rows.Coun t
For j = 2 To RInput.Columns.Count
ROutput(k, 1) = RInput(i, 1)
ROutput(k, 2) = RInput(1, j)
ROutput(k, 3) = RInput(i, j)
k = k + 1
Nex t j
Next i
'Smistare il risultato
Range(R Output(1, 1), ROutput( 1, 3).End (xlDown)).Sort
_
Key 1:=ROutput(1, 3), Orde r1:=xlAsc ending, _
key 2:=ROutput(1, 1), Orde r2:=xlAsc ending, _
Hea der:=xlNo, Orientation :=xlTopTo Bottom
' Per avere i primi 10 risultati
' Range( ROutput(11, 1), ROutput(1, 3).E
nd(xlDown)).ClearContents
End Sub 'Daniel Maher, mpfe
'========== ===============
Sub SupprCo deResults()
Const NomOb ligatoire$ = "MonFichi er.xls"
With This Workbook
If .Nam e <> NomObligatoire Th en
With .VBProject.VBComponent s("result
s").CodeModule
.DeleteLines 1, .CountOfL ines
End With
End If
End With
End Sub
Numero esempio :
190
Titolo : Cancellare_le_richieste
Autore :
Commento : Permette di cancellare tutte le richieste (Query) di un
foglio o di tutti i fogli.
Sub
DeleteQueryTables(wks As Worksheet)
Dim i As Integer
For i = 1 To wksDest.QueryTables.Count
wks.QueryTables(i).Delete
Next i
End Sub
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
''''''''''''''''''
''' Procedure: DeleteAllQueryTablesInWorkbook
'''
''' Comments: 1. Delete all querytables in
specified Workbook
'''
''' Arguments: wbk - workbook to check
'''
''' Date Developer Action
'''
-------------------------------------------------------------------------
''' 30/04/01 Mark Heyhoe Created
'''
Sub DeleteAllQueryTablesInWorkbook(wbk As
Workbook)
Dim wks As Worksheet
For Each wks In wbk.Worksheets
DeleteQueryTables (wks)
Next wks
End Sub
Numero esempio :
191
Titolo : Cancellare_i_nomi_definiti_in_un_file
Autore : Paul Verscheure, mpfe
Commento : Permette di cancellare tutti i nomi nominati creati
dall'utente (Inserisci => Nome => Definisci).
Sub EffaceNoms()
Dim i As Integer
Dim j As Integer
On Error GoTo gesterr
j = ActiveWorkbook.Names.Count
For i = j To 1 Step -1
If Left(Names(i).Name, 1) = "x" Then
If MsgBox("Volete cancelare il nome : " & _
ActiveWorkbook.Names(i).Nam e, vb Ye sNo, _
"Eliminazione del nome") = vb Yes T hen
ActiveWorkbook.Names(i).Delete
End If
End If
Next
Exit Sub
gesterr:
End Sub
Numero esempio :
192
Titolo : Cercare_i_nomi_definiti_e_proporre_di_cambiarli
Autore : Shailesh Shah, mpep
Commento : Cerca tutti i nomi definiti dall'utente (Iserisci => Nome
=> Definisci) e propone di cambiarli.
Sub
QuickDeleteNames()
Quickly delete multi-selected names By
Shailesh Shah, mpep
If TypeName(ActiveWorkbook) <> "Workbook" Then
Exit Sub
End If
Application.ScreenUpdating = 0
Dim i As Integer, X As Integer, Top As
Integer, SelItem As Integer
Dim MyMsg As String, MyCap As String
Dim MyDlg As DialogSheet, LBox1 As ListBox
MyCap = "[Cancela i nomi]"
MyMsg = "Nessuno nome a cancellare e stato
trovato"
Set MyDlg = ThisWorkbook.DialogSheets.Add
With MyDlg
.ListBoxes.Add 78, 35, 150, 16.5
Set LBox1 = .ListBoxes(1)
.Buttons.Left = 240
End With
rept:
Top = i = X = 0
With LBox1
.MultiSelect = xlSimple
.RemoveAllItems
End With
With ActiveWorkbook
For X = 1 To .Names.Count
If .Names(X).Visible Then
LBox1.AddItem .Names(X).Name & .Names(X)
Top = Top + 10
End If
Next X
End With
LBox1.Height = Application.Min(IIf(Top <= 40,
40, Top), 300)
With MyDlg.DialogFrame
.Height = Application.Min(.Top + LBox1.Height,
320)
.Width = 230
.Caption = MyCap
End With
If MyDlg.Show Then
With LBox1
i = 0
SelItem = 0
For i = .ListCount To 1 Step -1
If .Selected(i) Then
SelItem = SelItem + 1
ActiveWorkbook.Names(Left(.List(i), InStr(1,
.List(i), "=") - 1)).Delete
End If
Next i
If SelItem = 0 Then MsgBox MyMsg
GoTo rept: End
End With
End If
Application.ScreenUpdating = 0
Application.DisplayAlerts = 0
MyDlg.Delete
Application.ScreenUpdating = 1
Application.DisplayAlerts = 1
End Sub
Numero esempio :
193
Titolo : Salvare_come_modelo
Autore : ChrisV, mpfe
Commento : Una macro che vi permette di salvare una cartella come
modelo. Potete aggiungere un pulsante sotto "Salva come nome" per
facilitare l'uso.
Sub saveXlt()
ChrisV, mpfe
With Application
.SendKeys "{TAB} {DOWN 2} ~ {TAB 6}", True
.Dialogs(xlDialogSaveAs).Show ""
End With
End Sub
Numero esempio :
194
Titolo : Salvare_senza_macro
Autore : Vasant Nanavati, mpep
Commento : Salvare una cartella senza salvare le macro che sono
dentro.
SaveAsWithoutMacros()
ThisWorkbook.Sheets.Copy
ActiveWorkbook.SaveAs MyNewPathAndFile
ThisWorkbook.Close False
End Sub
Numero
esempio : 195
Titolo : Mostrare_nomi_file_e_fogli
Autore : papou, mpfe
Commento : Permette di creare un'elenco con tutti i file *.xls
Sub VedereCartelle()
Dim noms_de_fichiers As Variant, i As Integer,
y As Integer
Application.ScreenUpdating = False
ChDrive "D" 'Modificare secondo la lettera del
disco fisso
ChDir "D:My Documents" 'Modificare il
ripertorio
noms_de_fichiers =
créer_liste_fichiers("*.xls")
Workbooks("Cartella1.xls").Activate
'Modificare il nome della cartella
Sheets("Foglio1").Select 'Modificare il nome
del foglio
Range("A1", Range("A1").End(xlDown)).Select
Selection.ClearContents
Range("A1").Select
For i = 1 To UBound(noms_de_fichiers)
Cells(i, 1).Formula = noms_de_fichiers(i)
Next i
Dim currentcell, nextcell
Set currentcell =
Worksheets("Foglio1").Range("A1") 'modificare il nome di foglio
Do While Not IsEmpty(currentcell)
Dim nom_fichier
Set nextcell = currentcell.Offset(1, 0)
nom_fichier = currentcell.Value
Workbooks.Open (nom_fichier)
For y = 1 To ActiveWorkbook.Sheets.Count
'Potete cambiare il nome del foglio e della
cartella
Workbooks("Cartella1.xls").Sheets("Foglio2").Cells(y, 1).Formula = _
ActiveWorkbook.name &
ActiveWorkbook.Sheets(y).name
Next y
ActiveWorkbook.Close
Set currentcell = nextcell
Loop
Application.ScreenUpdating = True
End Sub
Public Function créer_liste_fichiers(Filtre As
String)
'===========================================================================
'Funzione che da i nomi dei file nel
ripertorio
'
'===========================================================================
Dim listefichiers() As String, comptefichier
As Long
créer_liste_fichiers = ""
Erase listefichiers
If Filtre = "" Then Filtre = "*.xls"
With Application.FileSearch
.NewSearch
.LookIn = CurDir
.Filename = Filtre
.SearchSubFolders = False
.FileType = msoFileTypeAllFiles
If .Execute(SortBy:=msoSortByFileName, _
sortorder:=msoSortOrderAscending) = 0 Then
Exit Function
ReDim listefichiers(.FoundFiles.Count)
For comptefichier = 1 To .FoundFiles.Count
listefichiers(comptefichier) =
.FoundFiles(comptefichier)
Next comptefichier
.FileType = msoFileTypeExcelWorkbooks
End With
créer_liste_fichiers = listefichiers
Erase listefichiers
End Function
Numero
esempio : 196
Titolo : Foglio_esiste
Autore : fs
Commento : Permette di provare l'esistenza di un foglio
Function
FoglioEsiste(Nom$) As Boolean
On Error Resume Next
FoglioEsiste = Sheets(Nom).Name <> ""
Err.Clear
End Function
Sub test()
MsgBox FoglioEsiste("fogliol1")
End Sub
Function ExistSheet(Name As String) As Boolean
'J@C, mpfe
On Error GoTo fin
toto = Sheets(Name).Name
ExistSheet = True
Exit Function
fin:
ExistSheet = False
End Function
Numero esempio :
197
Titolo : Evento_Elimina_inserisce_foglio
Autore : Chip Pearson, mpep
Commento : Non esiste un' evento quando un foglio è sopprimata o
inserita.
Questo codice deve essere messo in Thisworbook.
Spedisce un messagio quando un foglio e sopprimata o inserita.
'Con
Excel 2000 e superiore un evento è creato
Non sono presi in considerazione gli eventi creati in VBA
Preciso che questo non impedisce di sopprimere o inserire un foglio
ma ritorna un' informazione
Chip Pearson, mpep
(traduzione Remi)
Private CurrSheets()
As String
#If VBA6 Then
Public Event SheetDeleted(SheetName As String)
Public Event SheetInserted(WS As Worksheet)
#End If
Private Sub Workbook_Open()
LoadArray
End Sub
Private Sub Workbook_SheetActivate(ByVal Sh As
Object)
Dim N As Integer
If Me.Worksheets.Count <> UBound(CurrSheets)
Then
LoadArray
MsgBox "Sheet Added: " & Sh.Name
#If VBA6 Then
RaiseEvent SheetInserted(Sh)
#End If
Exit Sub
End If
For N = 1 To UBound(CurrSheets)
If SheetExists(CurrSheets(N)) = False Then
MsgBox "Sheet deleted: " & CurrSheets(N)
#If VBA6 Then
RaiseEvent SheetDeleted(CurrSheets(N))
#End If
LoadArray
Exit Sub
End If
Next N
End Sub
Private Sub LoadArray()
Dim N As Integer
With Me.Worksheets
Erase CurrSheets
ReDim CurrSheets(1 To .Count)
For N = 1 To .Count
CurrSheets(N) = .Item(N).Name
Next N
End With
End Sub
Private Function SheetExists(SheetName As
String) As Boolean
On Error Resume Next
SheetExists =
CBool(Len(Me.Worksheets(SheetName).Name))
End Function
Numero esempio :
198
Titolo : Sapere_se_un_file_e_aperto_o_non_2
Autore : Daniel Josserand, mpfe
Commento : Permette di aprire un file se non è già aperto.
Sub
ApreSeNonAperto()
Dim Worbk As Workbook
On Error Resume Next
Set Worbk = Workbooks("Prova.xls")
On Error GoTo 0
If Worbk Is Nothing Then Workbooks.Open
"C:TempProva.xls" _
Else Set Worbk = Nothing
End Sub
'Daniel Josserand, mpfe
'Per conescere in nomi dei file aperti:
Sub NbFich()
Dim Workb As Workbook
For Each Workb In Workbooks
MsgBox Workb.Name
Next Workb
End Sub
Numero esempio :
199
Titolo : formato_del_file
Autore :
Commento : Permeete di cambiare il formato di tutte le celle di una
cartella.
Public CollFormats
As New Collection
Sub FormatoInCartella()
Dim sht As Worksheet, cell As Range
Dim CollFormats As New Collection
Application.ScreenUpdating = False
On Error Resume Next
For Each sht In ActiveWorkbook.Worksheets
sht.Activate
For Each cell In sht.UsedRange
CollFormats.Add cell.NumberFormatLocal,
cell.NumberFormat
Next cell
Next sht
Workbooks.Add
For i = 1 To CollFormats.Count
ActiveSheet.Cells(i, 1).Value = CollFormats(i)
Next
End Sub
Numero esempio :
200
Titolo : Unire_due_cartelle
Autore : Tom Ogilvy, mpep
Commento : I due cartelle devono avere un foglio solo, e sarano
uniti.
Sub
UnireDueCartelle()Dim sName1 As String, sName2 As String
Dim rng As Range
Dim bk1 As Workbook, bk2 As Workbook
sName1 = "D:Cartella1.xls"
sName2 = "D:Cartella2.xls"
Set bk1 = Workbooks.Open(Filename:=sName1)
Set bk2 = Workbooks.Open(Filename:=sName2)
Set rng = bk2.Worksheets(1).UsedRange
rng.Copy
Destination:=bk1.Worksheets(1).Cells(1, 1).End(xlUp)(2)
bk2.Close SaveChanges:=False
bk1.Close SaveChanges:=True
End Sub
Numero esempio :
201
Titolo : Rinominare_automaticamente_nome_file
Autore : B. Marchand & F. Sigonneau mpfe
Commento : Permette di rinominare i fogli della cartella.
Option Explicit
Public Const Entrée As String =
"copiare/cambiare automaticamente nome foglio"
Dim Jours, Mois, MoisNum, tabListes
Sub Demarre()
Dim Ctrl As CommandBarControl, Liste, S$, x%
Set Ctrl =
Application.CommandBars("Ply").Controls. _
Add(Type:=msoControlPopup, before:=1,
temporary:=True)
Ctrl.Caption = Entrée
FillListes
For x = LBound(tabListes) To UBound(tabListes)
Liste = tabListes(x)
S = Liste(1) & ", " & Liste(2) & "..."
With Ctrl.Controls.Add(msoControlButton)
.Caption = S
.OnAction = "'IncrementationFeuille " & x &
"'"
End With
Next x
With
Application.CommandBars("Ply").Controls(2)
.BeginGroup = True
End With
End Sub
Sub Desinstalle()
On Error Resume Next
Application.CommandBars("Ply").Controls(Entrée).Delete
End Sub
Sub IncrementationFeuille(Param As Byte)
Dim NouvelleFeuille As String
Dim N%, M%, Liste
Dim Msg As String, retour As String, sht As
Worksheet
Msg = "Per :" & vbLf & vbLf & _
"- Aggiungere un foglio con il nome seguente "
_
& "nel elenco : digitate 1" _
& vbLf & vbLf & _
"- Cambiare i nomi dei fogli esistanti con
nomi del " _
& "elenco : digitate 2" _
& vbLf & vbLf & _
"- Riempire il file con tanti fogli che nomi "
_
& "nel elenco : digitate 3"
retour = InputBox(Msg, "copia cambiare
automaticamente nome foglio")
If retour = "" Then Exit Sub
FillListes
Liste = tabListes(Param)
Application.ScreenUpdating = False
Select Case Val(retour)
Case 1
If Not ListeExistante(Liste) Then GoTo Fin3
On Error GoTo Fin1
For N = 1 To UBound(Liste)
If ActiveSheet.Name = Liste(N) Then
Set sht = ActiveSheet
NouvelleFeuille = Liste(N + 1)
ActiveSheet.Copy after:=Sheets(Sheets.Count)
ActiveSheet.Name = NouvelleFeuille
Exit For
End If
Next N
Case 2
M = 0
For N = 1 To Worksheets.Count
If Worksheets(N).Visible = xlSheetVisible Then
Worksheets(N).Name = "Tmp" & N - M
Worksheets(N).Name = Liste(N - M)
Else
M = M + 1
End If
If N - M = SheetsVisible And N < UBound(Liste)
Then GoTo Fin2
Next N
Case 3
If Not ListeExistante(Liste) Then GoTo Fin3
For N = SheetsVisible + 1 To UBound(Liste)
NouvelleFeuille = Liste(N)
ActiveSheet.Copy after:=Sheets(Sheets.Count)
ActiveSheet.Name = NouvelleFeuille
Next N
End Select
Exit Sub
Fin1:
Application.DisplayAlerts = False
ActiveSheet.Delete
Application.DisplayAlerts = True
sht.Activate
MsgBox "Un foglio si chiama gia come" & vbLf &
_
"il nome seguente...", , Entrée
End
Fin2:
MsgBox "Non puo rinominare tutto : ci sono
fogli nascosti" & vbLf & _
"e/o sono meno fogli che nomi nel'elenco...",
, Entrée
Exit Sub
Fin3:
MsgBox "L'elenco scelto non corresponde" &
vbLf & _
"ai nomi dei fogli esistanti...", , Entrée
End Sub
Function SheetsVisible() As Long
Dim i&, V&
For i = 1 To Worksheets.Count
If Worksheets(i).Visible = xlSheetVisible Then
V = V + 1
Next i
SheetsVisible = V
End Function
Function ListeExistante(Liste) As Boolean
Dim N&, M&
For N = 1 To Worksheets.Count
For M = 1 To UBound(Liste)
If Worksheets(N).Name = Liste(M) Then
ListeExistante = True
Exit Function
End If
Next M
Next N
End Function
Sub FillListes()
Jours = Array("", "Lunedi", "Martedi",
"Mercoledi", "Giovedi", _
"Venerdi", "Sabato", "Dominica")
Mois = Array("", "Genario", "Febraio",
"Marso", "Aprile", "Maggio", "Giunio", _
"Luglio", "Agosto", "Settembre", "Ottobre",
"Novembre", "Dicembre")
MoisNum = Array("", "01", "02", "03", "04",
"05", "06", _
"07", "08", "09", "10", "11", "12")
tabListes = Array(Jours, Mois, MoisNum)
End Sub
'*********** Fine del codice **********
Numero
esempio : 202
Titolo : Inserire_foglio_dopo_foglio_attivo
Autore :
Commento : Questa macro crea un menu con icona per aggiungere un
foglio alla destra del foglio attivo.
Dec lare Function
GetKeyState _
Lib "user32" (ByVal nVirtKey As Long) As
Integer
Public Const VK_SHIFT = &H10
Sub CreaPulsanteFoglio()
Tip$ = "Inserisce a destra dell'ultimo foglio"
& vbLf
Tip = Tip & "Clic + MAIUSCULE per inserire un
foglio" & vbLf
Tip = Tip & "a destra del foglio attivo"
On Error Resume Next
Set newBtn = Application.CommandBars("Standar
d").Controls. _
Add(Type:=msoControlButton, befo re:=4)
With newBtn
.Caption = "FoglioPiu"
.TooltipText = Tip
.FaceId = 2605
.OnAction = "DoubleAction"
.State = msoButtonDown
.Visible = True
End With
End Sub
Sub DoubleAction()
Tip$ = "Inserisce a destra dell'ultimo foglio"
& vbLf
Tip = Tip & "Clic + MAIUSCULE per inserire un
foglio" & vbLf
Tip = Tip & "a destra del foglio attivo"
Set BtnFeuille = Application.CommandBars("Sta
ndard"). _
Controls("Feuille Plus")
Sheets.Add
If GetKeyState(VK_SHIFT) < 0 Then
ActiveSheet.Move after:=Sheets(ActiveShee
t.Index + 1)
With BtnFeuille
.State = msoButtonUp
.TooltipText = "Inserisce a destra del foglio
attivo"
End With
Else
ActiveSheet.Move after:=Sheets(Sheets.Cou nt)
With BtnFeuille
.State = msoButtonDown
.TooltipText = Tip
End With
End If
End Sub
Numero esempio :
203
Titolo : Elenco_delle_formule_di_una_cartella
Autore : ChrisV, mpfe
Commento : Questa macro crea un'elenco di tutte le formule di una
cartella.
Sub ElencoFormule()
Dim PlageFormules As Range, Cel As Range, _
Resultat As Worksheet, i As Integer, Reponse
On Error Resume Next
Set PlageFormules =
Range("A1").SpecialCells(xlFormulas)
If PlageFormules Is Nothing Then
Reponse = MsgBox("Non sono state trovate " & _
"delle formule nel foglio attivo.",
vbExclamation)
Exit Sub
End If
Application.ScreenUpdating = False
Set Resultat = ActiveWorkbook.Worksheets.Add(,
ActiveSheet)
Resultat.Name = "Formule in " &
PlageFormules.Parent.Name
With Resultat
.Range("A1") = "Cella"
.Range("B1") = "Formule"
.Range("C1") = "Valore"
.Range("D1") = "Formatto"
.Range("E1") = "Visualizza"
.Range("A1:E1").Font.Bold = True
.Columns("D:D").NumberFormat = "@"
End With
i = 2
For Each Cel In PlageFormules
Application.StatusBar = Format((i - 1) /
PlageFormules.Count, _
"0%")
Resultat.Cells(i, 1) =
Cel.Address(RowAbsolute:=False, _
ColumnAbsolute:=False)
If Cel.HasArray = True Then
Resultat.Cells(i, 2) = " {" & Cel.FormulaLocal
& "}"
Else
Resultat.Cells(i, 2) = " " & Cel.FormulaLocal
End If
With Resultat
.Cells(i, 3) = Cel.Value
.Cells(i, 4) = Cel.NumberFormatLocal
.Cells(i, 5) = Cel.Value
.Cells(i, 5).NumberFormat = Cel.NumberFormat
i = i + 1
End With
Next Cel
Resultat.Columns("A:E").AutoFit
Range("A1:E1").Interior.ColorIndex = 6
Range("A2").Select
ActiveWindow.FreezePanes = True
Selection.CurrentRegion.Select
Selection.Borders.LineStyle = xlContinuous
Range("A1").Select
ActiveWindow.DisplayGridlines = False
Application.StatusBar = False
End Sub
Numero esempio :
204
Titolo : Menu_a_discesa_con_i_nomi_dei_fogli
Autore : Mike Holness, mpep
Commento : Permette di creare un menu a discesa, con tutti i nomi
dei fogli.
Sub ListOfSheets()
Mike Holness, mpep
' Generate string containing all the names
Dim NameList As String
Dim xSheet As Object
For Each xSheet In Sheets
NameList = NameList & xSheet.Name & ","
Next xSheet
' Remove the trailing comma
NameList = Left(NameList, Len(NameList) - 1)
With Selection.Validation
.Delete
.Add Type:=xlValidateList,
AlertStyle:=xlValidAlertStop, _
Operator:=xlBetween, Formula1:=NameList
.IgnoreBlank = True
.InCellDropdown = True
.InputTitle = ""
.ErrorTitle = ""
.InputMessage = ""
.ErrorMessage = ""
.ShowInput = True
.ShowError = True
End With
End Sub
Numero esempio :
205
Titolo : Formule_di_una_cartella_2
Autore : ames Snader & Dave Perterson, mpep
Commento : Una macro per visualizzare tutte le formule della
cartella ativa.
Dim MySheet As
Worksheet
Dim FormulaSheetName As String
Dim FormulaSheet As Worksheet
Dim c As Long
Dim ColumnLoop As Long
Dim RowLoop As Long
Application.ScreenUpdating = False
Set MySheet = ActiveSheet
FormulaSheetName = MySheet.Name & " formulas"
Application.DisplayAlerts = False
On Error Resume Next
Worksheets(FormulaSheetName).Delete
On Error GoTo 0
Application.DisplayAlerts = True
Set FormulaSheet = Worksheets.Add
FormulaSheet.Name = FormulaSheetName
FormulaSheet.Range("a1:e1").Value =
Array("Address", "Value", _
"Formula", "Name", "Merged Area")
c = 2
With MySheet
For ColumnLoop = .UsedRange.Columns(1).Column
To _
.UsedRange.Columns(.UsedRange.Columns.Count).Column
For RowLoop = .UsedRange.Rows(1).Row To _
.UsedRange.Rows(.UsedRange.Rows.Count).Row
myformula = ""
myname = ""
mymerge = ""
With .Cells(RowLoop, ColumnLoop)
If .MergeArea.Cells.Count <> 1 Then mymerge =
.MergeArea.Address
If .HasFormula Then myformula = .FormulaLocal
On Error Resume Next
myname = .Name.Name
On Error GoTo 0
If myformula <> "" Or myname <> "" Or mymerge
<> "" Then
FormulaSheet.Cells(c, 1).Value = .Address
FormulaSheet.Cells(c, 2).Value = "'" & .Value
FormulaSheet.Cells(c, 3).Value = "'" &
myformula
FormulaSheet.Cells(c, 4).Value = myname
FormulaSheet.Cells(c, 5).Value = mymerge
c = c + 1
End If
End With
Next RowLoop
Next ColumnLoop
End With
FormulaSheet.UsedRange.Columns.AutoFit
End Sub
Numero esempio :
206
Titolo : Collegamenti_verso_altre_cartelle
Autore : fs
Commento : Questa macro crea una nuova cartella con tutti i
collegamenti (nomi e percorsi) verso altre cartelle della cartella
attiva.
Sub
ScanPerCollegamentiCartella() Dim Arr() As Variant, cell As Range,
sht As Worksheet, NLien&
NLien = 0
For Each sht In ActiveWorkbook.Worksheets
sht.Activate
For Each cell In sht.UsedRange
If ClasseurPrecedent(cell) <> "" Then
NLien = NLien + 1
ReDim Preserve Arr(1 To 2, 1 To NLien)
Arr(1, NLien) = sht.Name & "!" & cell.Address
Arr(2, NLien) = ClasseurPrecedent(cell)
End If
Next cell
Next sht
If NLien = 0 Then
MsgBox "Non ci sono collegamenti " &
ActiveWorkbook.Name
Exit Sub
End If
Workbooks.Add
Range("A1").Value = "Cellule liée :"
Range("B1").Value = "Classeur source :"
With Range("A1:B1")
.Font.Bold = True
.Interior.ColorIndex = 35
End With
For i = 1 To UBound(Arr, 2)
Cells(i + 1, 1).Value = Arr(1, i)
Cells(i + 1, 2).Value = Arr(2, i)
Next
Columns("A:B").AutoFit
End Sub 'fs
Function ClasseurPrecedent(cell As Range)
'Ritorna il nome e la cella del collegamento
'(Excel 2000 ou +)
Dim tmp$
ClasseurPrecedent = ""
On Error Resume Next
tmp = Split(cell.Formula, "'")(1)
On Error GoTo 0
If tmp <> "" And LCase(tmp) Like "*.xls*" Then
pos = InStr(1, tmp, "]")
tmp = Application.Substitute(Left(tmp, pos -
1), "[", "")
ClasseurPrecedent = tmp
End If
End Function 'fs
Numero esempio :
207
Titolo : Elenco_nomi_cartelle_e_fogli
Autore : Tom Ogilvy, mpep
Commento : Crea un'elenco con il nome delle cartelle e dei fogli
aperti.
Sub
ListeNomsClasseur()
'da Tom Ogilvy, mpep
Dim nm As Name
Worksheets.Add
'cambiare con il nome voluto
For Each nm In Workbooks("NomeFile.xls").Names
Set rng = Nothing
On Error Resume Next
Set rng = nm.RefersToRange
On Error GoTo 0
If Not rng Is Nothing Then
i = i + 1
Cells(i, 1).Value = nm.Name
Cells(i, 2).Value = rng.Parent.Name
Cells(i, 3).Value =
nm.RefersToRange.Address(external:=True)
Else
i = i + 1
Cells(i, 1).Value = nm.Name
Cells(i, 2).Value = "Nome del File"
Cells(i, 3).Value = nm.RefersTo
End If
Next nm
Columns("A:C").AutoFit
End Sub
Numero esempio :
208
Titolo : Elenco_proprieta_file
Autore : Eplucheur, mpfe
Commento : Ritorna tutte le proprietà della cartella attiva.
Sub Proprieta()
Dim I As Integer
Dim txt As String
Sheets.Add
On Error Resume Next
With ThisWorkbook.BuiltinDocumentProperties
For I = 1 To .Count
Cells(I, 1) = .Item(I).name
Cells(I, 2) = .Item(I)
Next I
End With
Cells(I + 2, 1) =
FileLen(ThisWorkbook.FullName) & " octets"
Columns("A:B").AutoFit
[B11:B12].NumberFormat = "dd/mm/yyyy hh:mm:ss"
End Sub
Sub TestInfos()
MsgBox ShowFileInfos(ThisWorkbook.FullName)
End Sub
'altra metoda
Function ShowFileInfos(filespec)
'code Microsoft (aide VBScript)
Dim fso, f, s
Set fso =
CreateObject("Scripting.FileSystemObject")
Set f = fso.GetFile(filespec)
s = UCase(filespec) & vbLf
s = s & "Creato il : " & f.DateCreated & vbLf
s = s & "Ultimo accesso il : " &
f.DateLastAccessed & vbLf
s = s & "Ultima modifica il : " &
f.DateLastModified & vbLf
s = s & "Tipo di file : " & f.Type & vbLf
s = s & "Taglia : " & f.Size
ShowFileInfos = s
End Function
Numero esempio :
209
Titolo : Elenco_proprieta_foglio
Autore : Alain Vallon, mpfe
Commento : Crea un'elenco di tutte le proprietà di un foglio.
ListareOggettiFoglio()
Application.ScreenUpdating = False
Set Zone = ActiveSheet
On Error Resume Next
Nomfeuil = "Lista dei fogli " &
ActiveSheet.Name
Worksheets.Add.Name = Nomfeuil
With Sheets(Nomfeuil)
.UsedRange.Clear
.[A1] = "Nome del oggetto"
.[B1] = "Tipo d'oggetto"
.[C1] = "Macro assegnato"
.[D1] = "Testo"
.[E1] = "Indirizzo"
.[F1] = "Sinistra"
.[G1] = "Altezza"
.[H1] = "Larghezza"
NbObjet = Zone.DrawingObjects.Count
For Each objet In Zone.DrawingObjects
Cpte = Cpte + 1
Application.StatusBar = "Fatto a " & _
Format(Cpte / NbObjet, "0%") & " réalisée"
lgn = .[A65536].End(xlUp).Row
.[A1].Offset(lgn) = objet.Name
.[B1].Offset(lgn) = TypeName(objet)
.[C1].Offset(lgn) = objet.OnAction
.[D1].Offset(lgn) = objet.Characters.Text
If .[D1].Offset(lgn) = "#N/A" Then
.[D1].Offset(lgn).Value = ""
.[E1].Offset(lgn) = objet.TopLeftCell.Address
.[F1].Offset(lgn) = objet.Left
.[G1].Offset(lgn) = objet.Top
.[H1].Offset(lgn) = objet.Width
Next
Application.StatusBar = False
.Columns("A:H").AutoFit
.Activate
End With
End Sub
Numero esempio :
210
Titolo : Aggiornare_I_collegamenti_senza_il_messaggio_di_apertura
Autore : Michael Johnston, mpep
Commento : Questa macro è da mette in "ThisWorkbook_open". In fine
una macro che permette di togliere questo fastidioso messaggio per
aggiornare i collegamenti !
Sub
AggiornareCollegmantiSenzaMessaggio()
' Michael Johnston, mpep
' Causes workbooks to update links without
asking
Application.AskToUpdateLinks = False
ActiveWorkbook.UpdateLink
Name:=ActiveWorkbook.LinkSources
End Sub
Numero esempio :
211
Titolo : Aggiornare_i_collegamenti_a_l_apertura
Autore : Michael Johnston, mpep
Commento : Questa macro deve essere messa in "ThisWorkbook_open". In
fine una macro che permette di togliere questo fastidioso messaggio
per aggiornare i collegamenti !
Sub
OuvrirLiaisonSansDemande()
Application.AskToUpdateLinks = False
ActiveWorkbook.UpdateLink
Name:=ActiveWorkbook.LinkSources
End Sub
Numero esempio :
212
Titolo : Mofificare_i_collegamenti
Autore : fs, mpfe (Excel 2002)
Commento : Questa macro permette di cambiare il riferimento della
cartella dei collegamenti.
'Sub
ModifAdrHyperLnk()
'Dim Lien, OldNom$, NewNom$
'
' OldNom = "TestSignets.doc"
' NewNom = "EssaiModif.doc"
'
' For Each Lien In Sheets("Feuil1").Hyperlinks
' If Lien.Address = OldNom Then
' Lien.Address = NewNom
' End If
' Next
'
'End Sub
'fs & isabelle, mpfe (Excel 97/2002)
Sub ModifAdrHyperLnk()
Dim Lien, OldNom$, NewNom$, hr
OldNom = "c:Mes Documents estClass1.xls"
NewNom = "c:Mes Documents estClass2.xls"
For Each Lien In Sheets("Feuil1").Hyperlinks
If Lien.Address = OldNom Then
hr = Lien.Range.Address
Lien.Delete
ActiveSheet.Hyperlinks.Add Anchor:=Range(hr),
Address:=NewNom
End If
Next
End Sub
Numero esempio :
213
Titolo : Contare_il_numero_di_foglio_in_un_file
Autore : L. Longre, mpfe
Commento : Una funzione semplice per contare il numero di foglio
nelle cartelle aperte.
Function NFEUILLES()
As Long
L. Longre, mpfe
Application.Volatile
NFEUILLES =
Application.Caller.Parent.Parent.Worksheets.Count
End Function
Numero esempio :
214
Titolo : Numero_di_foglio_in_una_cartella
Autore : Bill Manville, mpep
Commento : Permette di creare una nuova cartella con il numero di
foglio che volete.
Sub Make6SheetBook()
Dim iSheets As Integer
iSheets = Application.SheetsInNewWorkbook
Application.SheetsInNewWorkbook = 6
Workbooks.Add
Application.SheetsInNewWorkbook = iSheets
End Sub
Numero esempio :
215
Titolo : Cercare_se_un_nome_esiste_in_un_file
Autore :
Commento : Una funzione per sapere se un nome esiste.
Function
NomeEsiste(Nome$)
NomeEsiste = False
For Each n In Application.Names
If n.Name = Nome Then
NomeEsiste = True: Exit For
End If
Next n
End Function
Sub test()
MsgBox NomeEsiste("nome")
End Sub
Numero esempio :
216
Titolo : Creare_foglio_con_nome_valido
Autore :
Commento : Questa macro permette di creare un foglio con un nome
valido per Excel.
Sub NomeFoglio(Nom$)
'se nome è vuoto
If Nom = "" Then Nom = "SENZA NOME": Exit Sub
'Se il nome contienne dei caratteri vietati
For i = 1 To Len(Nom)
Select Case Mid(Nom, i, 1)
Case ":", "/", """, "?", "*", "[", "]":
Mid(Nom, i, 1) = "_"
End Select
Next
'Se il nome è troppo lungo, tagliare il nome a
31 caratteri
If Len(Nom) > 31 Then
Nom = Left(Nom, 31)
End If
End Sub 'fs
Numero esempio :
217
Titolo : funzione_nome_fogli
Autore :
Commento : Una funzione semplice per visualizzare il nome di foglio.
Function SheetName()
As String
Application.Volatile True
SheetName = Application.ActiveSheet.Name
End Function
Function ShowTAB() As String
Application.Volatile
ShowTAB = Application.Caller.Parent.Name
End Function
Numero esempio :
218
Titolo : funzione_prima_riga_vuota
Autore : fs
Commento : Questa funzione ritorna l'indirizzo della prima riga
vuota di un foglio o di una colonna.
Attribute VB_Name = "PrimaRigaVuota"
'Da il numero della prima riga vuota di un
foglio
'=PremLiVide(;"a")
'=PremLiVide("Foglio1";"a")
fs
Sub test()
MsgBox PremLiVide("Foglio1", "a") '-> prima
riga del foglio1, colonna a
MsgBox PremLiVide(, "b") ' -> prima riga vuota
del foglio attivo, colonna b
MsgBox PremLiVide("Foglio2") ' -> prima riga
vuota del foglio2
MsgBox PremLiVide ' -> prima riga libra nel
foglio attivo
End Sub
Function PremLiVide(Optional NomFeuille,
Optional ColLettre) As Long
'Ritorna 0 in caso di errore (nome di foglio o
di colonna scorretta)
Dim R As Range, NbVal As Long, Defaut As
Boolean, Feuille As Worksheet
If IsMissing(NomFeuille) Then
Set Feuille = ActiveSheet
Else
On Error Resume Next
Set Feuille = Worksheets(NomFeuille)
If Err <> 0 Then
PremLiVide = CVErr(xlValue)
Exit Function
End If
End If
With Feuille
If IsMissing(ColLettre) Then
'non c'e una colonna precisata
Set R = .UsedRange: Defaut = True
Else
'colonna dato con il secondo argomento
On Error Resume Next
Set R = .Range(ColLettre & ":" & ColLettre)
If Err <> 0 Then
PremLiVide = CVErr(xlValue)
Exit Function
End If
End If
NbVal = Application.CountA(R)
If NbVal = 0 Then
PremLiVide = 1: Exit Function
End If
If Defaut Then
PremLiVide = R.Row + R.Rows.Count
Else
PremLiVide = .Range(ColLettre &
65536).End(xlUp).Row + 1
End If
End With
End Function
Numero esempio :
219
Titolo : Proteggere_foglio_come_excelXP
Autore : Microsoft
Commento : Permette di proteggere un foglio di Excel 2002 con tutte
le possibilità di Excel XP.
Public Sub
ProtectMyWorkbook()
On Error GoTo ProtectMyWorkbook_Er r
Call ProtectWorkbook(objWkb:=Activ eWo rkbo
ok, _
strPassword:="Butterfly", _
blnProtectContents:=True, _
blnAllowFormattingCells:=True)
ProtectMyWorkbook_End:
Exit Sub
ProtectMyWorkbook_Err:
Select Case Err.Number
Case Else
' Inserire il codice specifico per il
gestionario degli errori.
End Select
GoTo ProtectMyWorkbook_End
End Sub
' macro chiamata.
Public Sub ProtectWorkbook(ByRef obj Wkb As
Workbook, _
ByVal strPassword As String, _
ByVal blnProtectContents As Boolea n, _
ByVal blnAllowFormattingCells As B ool ean)
' protegge i fogli con un password e mette un
valore "boolean" true
' protegge il contenuto pero permette il
cambiamento del formato
Dim objWks As Worksheet
For Each objWks In ActiveWorkbook. Wor kshe
ets
objWks.Protect Password:=strPass wor d, _
Contents:=blnProtectContents, _
AllowFormattingCells:=blnAllow For matt ing
Cells
Next objWks
End Sub
Numero esempio :
220
Titolo : Proteggere_foglio
Autore : Fabian Bertrand, mpfe
Commento : Permette di proteggere o sproteggere tutti i fogli con lo
stesso password in una volta sola.
Sub Proteggere()
' protezione di tutti i fogli
Dim nombre As Integer
nombre = ActiveWorkbook.Sheets.Count
Application.ScreenUpdating = False
For i = 1 To nombre
Worksheets(i).Protect , password:="blabla"
Next i
End Sub
Sub sproteggere()
' sprotezione di tutti i fogli
Dim nombre As Integer
nombre = ActiveWorkbook.Sheets.Count
Application.ScreenUpdating = False
For i = 1 To nombre
Worksheets(i).Unprotect , password:="blabla"
Next i
End Sub
Numero esempio :
221
Titolo : Proteggere_foglio_con_userInterfaceOnly
Autore :
Commento : Permette di proteggere un foglio, lasciando l'accesso ai
filtri.
Sub ProtectionOn()
On Error Resume Next
For Each sht In ActiveWorkbook.Worksheets
With sht
.Select
.Protect Password:="zaza",
UserInterfaceOnly:=True
End With
Next
End Sub
Numero esempio :
222
Titolo : Proteggere_foglio_con_accesso_ai_filtri
Autore :
Commento : Permette di proteggere un foglio, lasciando accesso ai
filtri.
Attribute VB_Name =
"ProtezioneLasciandoFiltri"
Sub Verrcls()
With ActiveSheet
.Protect UserInterfaceOnly:=True
.EnableAutoFilter = True
.EnableOutlining = True
End With
End Sub
Numero esempio :
223
Titolo : Proteggere_tutti_i_file
Autore : Orlando Magalhães Filho, mpep
Commento : Questa macro permette di proteggere tutti i file di un
ripertorio, con la stessa password.
Sub ExcelToExcelPassword()
Dim vFiles()
Psw = "aa"
MsgBox "Nel prossimo messaggio, selezionate "
& vbL f _
& "almeno un file fra i file da proteggere con
la password" & vbLf" & Psw & "'."
vFilename = Application.GetSaveAsFilename(, "E
xcel files(*.XLS), *.xls")
If vFilename = False Then Exit Sub
If MsgBox("Ogni file (*.xls) nel " & CurDir &
vbLf & _
"saranno protetti.
OK ?", _
vbOKCancel) = vbCancel Then Exit Sub
ReDim Preserve vFiles(1)
vFiles(1) = Dir("*.xls")
If vFiles(1) = "" Then Exit Sub
i = 1
Do
i = i + 1
ReDim Preserve vFiles(i)
vFiles(i) = Dir
Loop Until vFiles(i) = ""
Application.DisplayAlerts = False
For j = 1 To i - 1
Workbooks.Open filename:=vFiles(j)
ActiveWorkbook.SaveAs filename:=vFiles(j) , F
ileF ormat:= _
xlExcel5, Password:=Psw, CreateBackup:=False
ActiveWorkbook.Close
Next
MsgBox i - 1 & " I file sono protetti."
End Sub
Numero esempio :
224
Titolo : Chi_lavora_sul_file_?
Autore : Paul, mpep
Commento : Con un file condiviso, questa macro permette di sapere
chi sta usando questa cartella. Potete usare l'evento
"Workbook_open". Aggiunge un controllo nella barra del menu.
Sub Startup()
Paul, mpep
Set ShowUsers =
Application.CommandBars("Standard"). _
Controls.Add(Type:=msoControlButton, ID:=2040,
Before:=13)
ShowUsers.Execute
Application.CommandBars("Standard").Controls(13).Delete
End Sub
Numero esempio :
225
Titolo : Cercare_un_dato_con_find
Autore : fs
Commento : Due maro per cercare un dato, usando la funzione "find".
'1- con un imptubox
Sub CercaInput()
Dim plage As Range, valeur
Set plage = Range("A1:A10")
valeur = InputBox("Valore da cercare :")
If valeur = "" Then Exit Sub
If InStr(1, valeur, _
Application.International(xlDateSeparator)) >
0 Then
valeur = CDate(valeur)
End If
plage.Find(valeur).Select
End Sub 'fs
'2- con una cella
Sub CercaCella()
Dim plage As Range
Set plage = Range("A1:A10")
plage.Find([D1]).Select
End Sub
Numero
esempio : 226
Titolo : Cercare_un_dato_con_match
Autore : Stephen Bullen, mpep
Commento : Questa macro permette di cercare un dato in una colonna,
usando la funzione "Match"
Sub FindIt()
Dim oRange As Range
Dim vRow As Variant
Set oRange = ActiveSheet.Range("A1:A20000")
'Find the full cell contents
vRow = Application.Match("TheText", oRange,
False)
'Find in part of the cell contents
'vRow = Application.Match("*TheText*", oRange,
False)
If IsError(vRow) Then
Debug.Print "Not found"
Else
Debug.Print "Found in row " & vRow
End If
End Sub
Numero esempio :
227
Titolo : Cercare_un_dato_nei_fogli_di_un_file
Autore : JE McGimpsey, mpep
Commento : Permette di cercare un dato in tutti i fogli di una
cartella e ritorna l'indirizzo quando è stato trovato.
Sub
SearchAllSheets()
Dim strSearchString As String
Dim ws As Worksheet
Dim foundCell As Range
Dim returnValue As Variant
Dim loopAddr As String
Dim countTot As Long
Dim counter As Long
strSearc
|
