domenica 13 febbraio 2011
Corno di Medale - Via Cassin
Ero già in strada alle 7.10 quando mannaggia! inizia a piovere ... Beh mal che vada beviamo il caffè e torniamo a casa ...
La giornata è cominciata così, la Cassin è la via più facile del Medale ... 350 metri di 4°-5° ... è la via sicuramente più unta, diciamo pure saponosa :-) perdersi è impossibile anche per chi la sale per la prima volta ... basta seguire il luccichio della roccia.
E' una via a cui però sono affezionato, è la via di inizio stagione la prima quando si è proprio giù d'allenamento e si vuole riprendere a scalare ... è il mio caso attuale :-)
Oggi però la via non era solo unta era anche (almeno per i primi 5 tiri) sporca ... sporchissima di terra, una combinazione (unto e terra) da far venire la tremarella. Stanno richiodando 1 forse 2 vie a destra, dove c'è Sulla rotta di Poseidone ... credo siano la Via della Formica e la via dei Ragni .... però non ne sono sicuro ... fatto è che quella parte di parete a destra della Cassin è solcata da 2 serie di corde fisse ... così mentre ripuliscono e mettono in sicurezza, sporcano la super classica ... un consiglio quindi a chi volesse salirla, aspettate una bella pioggia :-)
Qui sotto la parete vista dall'attacco
Ci cambiamo ...
In sosta fumiamo :-)
Le scarpe ... ne ho un paio nuovo ... ma fanno ancora male ...
Però queste oramai sono proprio da buttare :-)
Mi sembra quasi di scalare a piedi nudi (quello bianco in effetti è proprio il pollice :-)
Il tiro più famoso, l'ardito traverso ...
E qui sotto un primo piano del traverso ... la parte bianca è la roccia martellata per renderla ruvida ... purtroppo l'esito non garantisce maggiore presa ... i piedi scivolano come sul ghiaccio ...
sabato 5 febbraio 2011
Una gita in Grignetta
Con Marco e Noureddine siamo stati in Grignetta ... "c'è troppa neve Marco per scalare in Grigna, andiamo in Medale" ... "ma va ... figurati ... andiamo con le scarpe del tennis" ... infatti :-) è vero siamo andati con le scarpe del tennis, e abbiamo scalato sul secondo Magnago (via Gandini) ... un tiro, due ... (che fatica sullo strapiombo ... sono proprio una sega e a scalare non ti regala niente nessuno ... Robb ti devi allenare!) ... comunque terzo tiro ... e... a casa, via a casa, doppie e via :-) ghiaccio e neve e anche se li è solo terzo a casa! anzi al bar per una birra :-)
Temperatura quasi estiva al sole ... in ombra e quando sul terzo tiro siamo scappati, faceva freddino ... ma appena appena di quello che non da fastidio.
mercoledì 17 febbraio 2010
Contare massimo numero di valori consecutivi
La formula matriciale qui sotto restituisce il massimo numero di celle consecutive che contengono un valore uguale a quello in B1
=MAX(FREQUENZA(SE(A1:A10=B1;RIF.RIGA(A1:A10));SE(A1:A10<>B1;RIF.RIGA(A1:A10))))
Una variante consente di contare il numero massimo di celle vuote (o meglio vuote o contenenti "")
=MAX(FREQUENZA(SE(A1:A10="";RIF.RIGA(A1:A10));SE(A1:A10<>"";RIF.RIGA(A1:A10))))
ancora ... stessa valutazione ma su più parametri ...
dati in A1:B10 ... parametri in C1 e D1 questa formula:
=MAX(FREQUENZA(SE((A1:A10=C1)*(B1:B10=D1);RIF.RIGA(A1:A10));SE((A1:A10=C1)*(B1:B10<>D1);RIF.RIGA(A1:A10))))
restituisce il numero massimo consecutivo di valori che rispettano le condizioni:
A1:A10 uguale a C1 e B1:B10 uguale a D1
saluti
r
mercoledì 20 gennaio 2010
Una frana a Scarenna ... o forse no?
L'anno scorso ricordo uno striscione appeso sulla roccia ... c'era scritto "No alla cava".
Sembrava che volessero *chiudere* la falesia, quel calcare prezioso serviva per produrre cemento ... poi pìù nulla.
Domenica la sorpresa, 100 metri prima della falesia ... la strada è bloccata, una frana invade la carreggiata della piccola strada che costeggia la palestra di roccia.
Frana naturale ... o frana *voluta?
Pensare male è peccato ... ma spesso ci si azzecca.
E tu come la pensi?
ciao
r
p.s. Le foto della frana


martedì 12 gennaio 2010
Maiuscolo iniziale migliorato
La function (anche UDF) che propongo permette di convertire un testo esteso in modo da rispettare alcune regole grammaticali. Il testo passato come argomento viene modificato infatti solo nelle lettere di inizio frase, nelle lettere che seguono ad un ritorno a capo e nelle lettere che seguono un punto, un punto esclamativo e un punto interrogativo. Segue una routine per testare il risultato.
Sarebbe possibile fare il trim prima o la conversione a lcase ... ma volendo, appunto, se desiderato si può farlo prima di passare l'argomento alla function.
Saluti
r
Function MaiuscoInizialeMigliorato( _
ByVal s As String) As String
'__________________________________________
'¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯
'Di Roberto Mensa nick r
'__________________________________________
'¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯
Dim v, i As Long
Dim re As Object
Set re = CreateObject("vbscript.regexp")
re.Pattern = _
"(^|[.!?]\b|[.!?]\s+\b|\r\b|\f\b|\n\b)(.)"
re.Global = True
MaiuscoInizialeMigliorato = _
re.Replace(s, "$1§$2§")
v = Split(MaiuscoInizialeMigliorato, _
"§", , vbTextCompare)
For i = 1 To UBound(v) Step 2
v(i) = VBA.StrConv(v(i), vbUpperCase)
Next
MaiuscoInizialeMigliorato = Join(v, "")
End Function
Sub test()
Dim s As String
s = "questo è un testo di prova. " & _
"tutto minuscolo." & _
vbNewLine & _
"le minuscole diventano maiuscole" & _
" se a inizio frase!" & _
vbNewLine & _
"le minuscole diventano maiuscole" & _
" se dopo un punto, punto " & _
"esclamativo o un punto di domanda" & _
vbNewLine & _
"le minuscole diventano maiuscole" & _
" se dopo un a capo."
MsgBox s, vbOKOnly, "prima"
MsgBox MaiuscoInizialeMigliorato(s), _
vbOKOnly, "Dopo"
End Sub
lunedì 11 gennaio 2010
Cavandoli test ... il secondo test per esperti di Excel
Buon divertimento :-)
saluti
r
p.s.
scorrendo poi fino in fondo troverete anche un mio ritratto :-)
ho dovuto colorare a mano quasi 100.000 celle
ci credete vero?
:-)
venerdì 8 gennaio 2010
Attrattori Strani (Peter de Jong - Grafici Excel)
Ben presto mi sono appassionato a questo gioco di curve e casualità ... così ho preparato una cartella di excel che consente di *giocare* nel vero senso della parola, con le curve di Peter de Jong ... poi ho trovato una variante e ne ho inventate altre due (la numero 3 e 4) giusto per rendere il gioco più vario :-)
Nel file che potete scaricare cliccando Qui (il file contiene macro e va salvato per evitare errori nell'esecuzione delle stesse) troverete tutto il necessario per creare serie casuali, salvare le più belle, creare in automatico grafici di differenti colori e con numero differenti di punti ... da 10.000 a 200.000 ... è consigliabile giocare con serie di 10.000 punti per eventualmente aumentarne dopo il numero di punti, questo consentirà di avere aggiornamenti veloci del grafico oppure vedere quale risultato restituisce la stessa serie con le varianti 2, 3 o 4.
Un esempio

il link della discussione nell'NG
il link nel blog di Giovana
Saluti
r
lunedì 4 gennaio 2010
Convertitore di Valuta (Componente aggiuntivo Excel 2003)
Quello che propongo è uno strumento di conversione delle valute.
Il componente aggiuntivo è scaricabile cliccando Qui.
Su come e dove salvare il componente aggiuntivo consultate la guida in linea al paragrafo:
"Risolvere i problemi relativi ai componenti aggiuntivi"
Una volta salvato il file sarà possibile aggiungere i riferimenti dal menu Strumenti->Componenti aggiuntivi ... eventualmente è possibile utilizzare il pulsante sfoglia per cercare il file.
Il convertitore utilizza una connessione tramite Internet Explorer a Google, lancia poi una ricerca tramite l'uso di parole chiave recuperando il risultato dello strumento calcolatrice di Google ...
un esempio può facilmente illustrare cosa avviene ... questa è una stringa che consente di eseguire in google una ricerca del tipi converti un euro in dollari statunitensi:
http://www.google.it/search?q=1+EUR+in+USD
Nella pagina che vi si apre noterete in alto il risultato dello strumento calcolatrice di google ... quel numero è ciò che viene recuperato come risultato della conversione dal componente aggiuntivo ... :-)
In questo modo deleghiamo a Google l'aggiornamento degli indici di conversione ... un grazie sentito :-)
Una volta aggiunto il componente all'apertura di Excel verrà creata una barra non ancorata con un pulsante per visualizzare la Form del convertitore.

Nelle due Combo sono visualizzati gli elenchi delle valute utilizzabili nella conversione.
Nella prima colonna troverete il codice di 3 lettere che si riferisce alla valuta (ad esempio EUR per l'euro), nella seconda il nome della valuta e nella terza i paesi in cui viene utilizzata.
Cliccando sui titoli di colonna otterrete l'ordinamento alternativamente crescente e decrescente ad ogni click relativamente al titolo su cui volete l'ordinamento.
Alla chiusura della form il risultato della conversione viene copiato in memoria, sarà quindi disponibile ad essere incollato nella cella desiderata.
Non scegliendo alcun valore dalla seconda combo, la conversione avverrà di defoult in euro.
E' superfluo dire che perchè funzioni correttamente deve essere installato Internet Explorer e il computer deve essere connesso a Internet.
Il progetto VBA non è protetto, il codice non è però commentato, anche se sarà facile capirne il funzionamento.
Che dire ... buon divertimento
Saluti
r
p.s.
cliccando Qui è possibile scaricare la cartella di lavoro (xls) ... successivamente potrete salvare con nome come componente aggiuntivo di Excel, in questo modo il file xla verrà salvato automaticamente nella cartella dove sono contenuti i AddIns
domenica 6 dicembre 2009
Sogni proibiti - Antimedale (Lecco)
Giacomo è molto che non lo incontro, un abbraccio e tante pacche sulle spalle, non è cambiato (a parte la barba imbiancata :-) Jack l'artista ... Jack il matto ... al bar li immortalo, un bianchino di prima mattina per cominciare bene la giornata.

Guido viene da un infortunio ... è caduto un po' di tempo fa ... si è rotto le costole ed oggi riprende per la prima volta a scalare ... dimenticavo ... è caduto dalle scale :-) mica mentre scalava ... oh Guido ... comunque loro andranno a fare la Chiappa io e Marco puntavamo alla Bonatti in Medale ma da sotto la ferrata vediamo che è ancora bagnata (ha piovuto venerdì) ... così decidiamo per Sogni proibiti nell'antimedale.
Si attacca sulla via degli istruttori ... dopo i primi due tiri si traversa a destra per 100 metri rimontando verso il pilastro a destra del canale ... la via attacca proprio dove c'è l'albero ... in tutto sono altri 4 tiri ... il primo ti sveglia fuori, fa anche un po' freddo ...
Via nel complesso faticosa (per il nostro livello di allenamento) diciamo che le difficoltà sono di 5°-6° sostenuti tirando un po' di chiodi ... in libera credo 6c ... noi alla libera non ci pensiamo nemmeno e già così ne usciamo rotti ... nella via uso anche alcuni nuts (medio piccoli) e frend (medio piccoli) ... non l'avevo ancora ripetuta da quando è stata richiodata ... e come già accaduto ... snaturata ... così alcuni passaggi sono più obbligati ... sul terzo tiro sono aggiunti due fittoni su una placca a lato del percorso originale (un diedro giallo con alcuni frigoriferi appoggiati) ... la placca sembra dura quindi rimango sui blocchi ... fare attenzione a cosa prendo in mano mi dico ... si sbuca sulla ferrata del Medale all'altezza dell'attacco di Bonatti e Brianzi ... ma ... per oggi a noi basta così ... andiamo in vetta per fare due passi ancora e fumare una sigaretta.
Marco attacca la via degli istruttori ...

Marco sul secondo tiro

giovedì 19 novembre 2009
Organigrammi - Excel 2003
Quello che propongo è un lavoro di quest'estate, mi ero ripromesso di apportare alcune modifiche, purtroppo non ho ancora avuto il tempo ... e ho paura che non lo avrò ancora per molto ... quindi prima che finisca nel dimenticatoio ... eccolo ... sotto la descrizione sommaria ...
il file è scaricabile cliccando qui
Attenzione! per il corretto funzionamento il file va salvato, contiene infatti Riferimenti aggiunti.
Versione Excel 2003
Contiene macro - Riferimenti aggiunti a:
- Microsoft Window Common Controls 6.0 (SP&)
- Microsoft Scripting Runtime
- Controlli TreeView e Spreadsheet (un messaggio iniziale chiederà di attivare i controlli ActiveX)
Descrizione:
All''apertura del file viene creata una Barra non ancorata contenente due pulsanti. Il primo "Creazione Guidata" richiama
Il secondo richiama una Form che aiuta nell'aggiunta di nodi direttamente su un foglio origine dati.
La creazione di organigrammi è semplificata grazie all'uso di una TreeView che aiuta a visualizzare la classica struttura ad albero sono poi presenti opzioni che consentono la modifica, l'eliminazione, l'aggiunta o lo spostamento dei nodi.
Una Form contenente un controllo Spreadsheet consente l'aggiunta di più nodi ad un unico nodo padre.
Ad ogni nodo sono associati due campi testo più la possibilità di scegliere se il nodo è un subordinato o un collaboratore.La creazione di diagrammi gerarchici prevede la possibilità di organizzare il campo testo delle singole caselle, grazie ad una Form dedicata.
E' possibile creare i diagrammi in un documento Word, una presentazione PowerPoint oppure in un nuovo Foglio o in una nuova Cartella Excel.
E' possibile scegliere il Layout del primo nodo e dei nodi successivi.
Organigrammi molto grandi producono diagrammi di difficile visualizzazione, per questo dato un organigramma è possibile isolare un singolo ramo e trattarlo separatamente.
Il salvataggio dei dati che costituiscono l'organigramma o il ramo isolato è consentito in due formati di foglio Excel e due di file XML. Questa seconda opzione è molto sperimentale e forse più una curiosità che una utilità vera e propria, comunque il formato
XML 2D trasforma l'organigramma in una tabella che successivamente riaperta in excel come elenco mostrerà l'organigramma come una normale tabella in cui ogni colonna è un livello sempre più esterno della struttura.
Il formato XML 3D invece crea uno schema analogo alla visualizzazione nella TreeView.Nel foglio Esempio1 viene mostrato come creare un foglio di Origine del tipo O_P_ a partire da una semplice tabella.
Nel foglio Esempio2 viene mostrato come è possibile usare un elenco di path per generare un Organigramma.
I fogli con prefisso E_ vengono utilizzati come elenchi di nodi da organizzare nella creazione dell'organigramma. Di questi fogli viene estratto l'elenco univoco dei testi e reso disponibile nella combo di assegnazione del nuovo nodo, una volta aggiunto il nodo la voce viene eliminata dalla combo. E' anche possibile copiare in memoria per esempio una serie di celle e ottenere lo stesso
risultato. Se la memoria è invece occupata da un testo verrà creato l'elenco con le singole parole lunghe almeno 4 caratteri.
Per imparare ad usare questo strumento il modo migliore è creare un organigramma a partire da zero, giocarci, salvare l'origine dati riaprirla e modificarla. I fogli presenti nella cartella sono origini dati già create con le quali è possibile fare prove.In particolare i fogli Modello_Oggetti ricostruiscono lo schema del modello delle applicazioni Office.
Questa cartella si presta ad essere trasformata in un componente aggiuntivo salvandola come xlm.
Il codice del progetto è commentato, le routine sono state divise in 3 moduli per chiarezza nella lettura. Il codice delle form è commentato solo parzialmente. Le funzioni nel modulo Funzioni sono molto generiche e riutilizzabili, consiglio quindi di leggerle attentamente.
saluti
r
mercoledì 18 novembre 2009
UDF Join
Function mcat(ParamArray S()) As String
'Copyright (C) 2002, Harlan Grove
'This is free software. It's use in derivative works is covered
'under the terms of the Free Software Foundation's GPL. See
'http://www.gnu.org/copyleft/gpl.html
'------------------------------------
'string concatenation analog to SUM
Dim R As Range, x As Variant, y As Variant
For Each x In S
If TypeOf x Is Range Then
For Each R In x.Cells
mcat = mcat & R.Value
Next R
ElseIf IsArray(x) Then
For Each y In x
mcat = mcat & IIf(IsArray(y), mcat(y), y)
Next y
Else
mcat = mcat & x
End If
Next x
End Function
da questa funzione ho tratto spunto per creare una UDF simile all'utilissima Join di VB ... JoinUDF restituisce una stringa creata dall'unione di sottostringhe contenute nel parametro Source e delimitate dal parametro Delimiter.
Source sarà quindi un range di più celle o una matrice, Delimiter potrà essere un qualsiasi valore, oppure un range o una matrice (in questi casi sarà il concatenamento delle sottostringhe).
Analogamente a Join questa funzione può essere usata per concatenare stringhe, omettendo Delimiter infatti verrà usato come delimitatore la stringa di lunghezza zero (la funzione Join viceversa usa come defoult lo spazio).
Function JoinUDF( _
Source As Variant, _
Optional Delimiter As Variant = "") As String
'di Roberto Mensa Nick r
Dim Rng As Range, x() As String, y As Variant
Dim i As Long
If TypeName(Source) = "Range" Then
ReDim x(Source.Count - 1)
For Each Rng In Source
x(i) = CStr(Rng.Value)
i = i + 1
Next
ElseIf IsArray(Source) Then
For Each y In Source
ReDim Preserve x(i)
x(i) = CStr(IIf(IsArray(y), JoinUDF(y), y))
i = i + 1
Next
Else
ReDim x(0)
x(0) = CStr(Source)
End If
If IsArray(Delimiter) Or TypeName(Delimiter) = "Range" Then
Delimiter = JoinUDF(Delimiter)
End If
JoinUDF = Join(x, CStr(Delimiter))
End Function
saluti
r
mercoledì 4 novembre 2009
Grafici a Cruscotto (Excel)
allego due file, ho aggiunto un effetto acceleratore, le Macro contenute riguardano solo questo ... per il resto funzionano con le normali funzionalità di Excel
Link 1
Link 2
saluti
r
Osvaldo Cavandoli - Grafici a dispersione (Excel)
Link al file
saluti
r
martedì 3 novembre 2009
Scomposizione in fattori primi (VB)
Saluti
r
Public Function Fattori_primi( _
ByVal N As Long)
Dim F As Long
Dim T As Long
Dim R As Long
Dim S As String
'si basa sul principio che un numero
'e primo se non ha divisori > della
'sua radice
R = Sqr(N)
T = N Mod 2 + 1
F = 1
If N = 1 Then
S = N
Else
Do Until F > R
F = F + T
If (N) Mod F = 0 Then
S = S & F & "*"
N = N / F
F = F - T
R = Sqr(N)
End If
Loop
If N = 1 Then
S = Left(S, Len(S) - 1)
Else
S = S & N
End If
End If
Fattori_primi = S
'volendo una matrice sostituire con
'Fattori_primi = Split(S, "*")
End Function
Public Function PrimiB2(ByVal N As Long) As Long()
'di Nur
Dim arrF() As Long
Dim F As Long, NP As Long, d As Long
Dim Stp As Long, Radice As Long
If N = 1 Then
ReDim arrF(0)
arrF(0) = 1
Else
Radice = Sqr(N)
d = 1
Stp = N Mod 2 + 1
Do Until d > Radice
d = d + Stp
If N Mod d = 0 Then
NP = NP + 1
ReDim Preserve arrF(NP - 1)
arrF(NP - 1) = d
N = N / d
d = d - Stp
Radice = Sqr(N)
End If
Loop
If d < N Then
ReDim Preserve arrF(NP)
arrF(NP) = N
ElseIf d = 1 Then
ReDim arrF(0)
arrF(0) = N
End If
End If
PrimiB2 = arrF
End Function
TextBox con convalida dati (MSForm - VBA - VBScript)
Propongo un esempio che utilizza le Espressioni Regolari per verificare se il dato è stato scritto correttamente. Il controllo viene eseguito nell'evento Exit e utilizza una routine generica a cui viene passato il pattern. Ho preferito avvisare l'utente scrivendo in un controllo Label l'eventuale messaggio di errore, piuttosto che utilizzare fastidiosi messaggi di errore.
'xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx
'per l'esempio inserire una nuova
'UserForm (UserForm1) contenente:
'una Label (Label1) e tre TextBox
'(TextBox1, TextBox2, TextBox3)
'xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx
'altri path si trovano a questo indirizzo:
'http://excelvba.altervista.org/blog/index.php/Excel-VBA/Espressioni-Regolari-e-Pattern-applicazione-Form.html
'Incollare tutto il codice nel modulo
'di classe della Userform
Private Sub UserForm_Initialize()
With Me
.Caption = "Esempi TextBox con convalida"
.Label1.Caption = ""
.Label1.ForeColor = &HFF&
.TextBox1.Tag = "Data Europea"
.TextBox2.Tag = "Codice Fiscale"
.TextBox3.Tag = "Numero decimale"
.TextBox1.Text = "12/10/2009"
.TextBox2.Text = "DVXJHT61B12Z600F"
.TextBox3.Text = "2,5"
End With
End Sub
Private Sub TextBox1_Exit(ByVal Cancel As MSForms.ReturnBoolean)
'data europea
UserForm_Controllo_Event_Exit Me.Label1, _
Me.TextBox1, _
Cancel, _
"^(3[01][12]\d0?[1-9])/(0?[13578]1012)/" & _
"(\d{2}(192021)\d{2})$" & _
"^(30[12]\d0?[1-9])/(0?[469]11)/(\d{2}" & _
"(192021)\d{2})$" & _
"^(2[0-8][01]\d0?[1-9])/(0?2)/(\d{2}" & _
"(192021)\d{2})$" & _
"^29/(0?2)/(200000)$" & _
"^29/(0?2)/(192021)?(0[48][2468][048]" & _
"[13579][26])$"
End Sub
Private Sub TextBox2_Exit(ByVal Cancel As MSForms.ReturnBoolean)
'codice fiscale
UserForm_Controllo_Event_Exit Me.Label1, _
Me.TextBox2, _
Cancel, _
"^([A-Z]{6})" & _
"(((\d{2})[ACELMRT](3[01][12]\d0[1-9]" & _
"7071[56]\d4[1-9]))" & _
"((\d{2})[DHPS](30[12]\d0[1-9]70" & _
"[56]\d4[1-9]))" & _
"((\d{2})B(2[0-8]1\d0[1-9]6[0-8]5\d4[1-9]))" & _
"((0[048][2468][048][13579][26])B(2969)))" & _
"([A-Z]{1})([0-9L-NPQ-V]{3})" & _
"([A-Z]{1})$"
End Sub
Private Sub TextBox3_Exit(ByVal Cancel As MSForms.ReturnBoolean)
'numero a virgola mobile
UserForm_Controllo_Event_Exit Me.Label1, _
Me.TextBox3, _
Cancel, _
"^(0[+-]?" & _
"((?!0)\d+([,]\d+)?" & _
"[0]+([,]\d+)?))$"
End Sub
Sub UserForm_Controllo_Event_Exit( _
ByRef oLabel As MSForms.Label, _
ByRef oControl As MSForms.Control, _
ByRef Cancel As MSForms.ReturnBoolean, _
Optional ByVal sPattern As String = "[\w\s]+")
'______________________________________________
'¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯
'Di Roberto Mensa nick r
'______________________________________________
'¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯
'Effettua un controllo sul testo digitato in un
'controllo, se il controllo ha esito negativo
'ripassa cancel=true impedendo l'uscita del focus
'e seleziona l'intero testo digitato
'da richiamare dall'evento exit di controlli che
'hanno cancel come argomento
'oLabel è il controllo Label entro cui comunicare
'il messaggio di errore
Dim re As Object
Static sLabelCaption As String
Static bCancel As Boolean
If bCancel = False Then
sLabelCaption = oLabel.Caption
End If
Set re = CreateObject("vbscript.regexp")
re.Pattern = sPattern
re.ignorecase = True
With oControl
If Len(.Text) > 0 Then
If re.test(.Text) = False Then
oLabel.Caption = _
"Testo " & .Tag & " - Non valido!"
.SelStart = 0
.SelLength = Len(.Text)
Cancel = True
bCancel = True
End If
End If
End With
If Cancel = False Then
bCancel = False
oLabel.Caption = sLabelCaption
End If
End Sub
lunedì 2 novembre 2009
CSV per ogni foglio della Cartella Excel attiva (Excel - VBA)
Il salvataggio con nome dei file di questo tipo infatti eseguito da codice VB non riconosce i delimitatori decimali in modo corretto, così la virgola viene sostituita dal punto ...
Viene usato un riferimento alla libreria Scripting per utilizzare l'oggetto FileSystemObject.
Per conoscere l'enorme potenzialità del FSO troverete molti esempi nella guida in linea di VBScript. Leditor VBScript è raggiungibile dal menu Strumenti->Macro->Microsoft Script Editor ... (potrebbe essere richiesta l'installazione al primo accesso eventualmente dare OK) ... nella guida in linea dell'editor è poi consultabile il capitolo vbscript all'interno del quale troverete gli argomenti legati al FileSystemObject.
Saluti
r
Option Explicit
'in un modulo standard del progetto VBA
Sub csv_tutti_i_fogli()
'______________________________________________
'¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯
'Di Roberto Mensa nick r
'______________________________________________
'¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯
'crea per ogni foglio della cartella di lavoro
'un file csv o txt (modificando la costante
'Estensione_file)
'i file vengono salvati nel percorso nella stessa
'posizione della cartella attiva
'se un file csv con lo stesso percorso-nome esiste
'già sarà sovrascritto
Dim Sh As Excel.Worksheet
Dim Rng As Excel.Range
Dim S As String
Dim FSO As Object
Dim tS As Object
Dim Wb As Excel.Workbook
Dim sPath As String
Const ForWriting As Long = 2
Const Estensione_file As String = ".csv"
Set Wb = ActiveWorkbook
Set FSO = CreateObject("Scripting.FileSystemObject")
sPath = Wb.Path '<< eventualmente da cambiare
On Error Resume Next
For Each Sh In Wb.Worksheets
Set Rng = UsedRange_Value(Sh, , True)
S = CSV_text(Rng)
Set tS = FSO.OpenTextFile(FSO.BuildPath( _
sPath, Sh.Name & Estensione_file _
), ForWriting, True)
tS.Write S
tS.Close
Next
End Sub
Function CSV_text( _
Rng As Excel.Range, _
Optional D As String = ";") As String
'______________________________________________
'¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯
'Di Roberto Mensa nick r
'______________________________________________
'¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯
'il parametro opzionale D indica il delimitatore
'da utilizzare nella scrittura del file
Dim R As Long, C As Long
Dim S As String, St As String
For R = 1 To Rng.Rows.Count
St = ""
For C = 1 To Rng.Columns.Count
St = St & D & Rng(R, C).Text
Next C
If Len(Replace(St, D, "")) Then
St = Right(St, Len(St) - 1)
Else
St = ""
End If
S = S & St & VBA.Constants.vbNewLine
Next R
CSV_text = VBA.Left(S, Len(S) - 2)
End Function
Function UsedRange_Value( _
Optional Sh As Worksheet, _
Optional Rng As Range, _
Optional WithFormulas As Boolean = False) _
As Excel.Range
'______________________________________________
'¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯
'Di Roberto Mensa nick r
'______________________________________________
'¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯
'Restituisce il minimo range rettangolare
'che comprende tutte le celle valorizzate
'nel foglio o nel range che passiamo come
'argomento
'Restituisce Nothing se nessuna cella è
'valorizzata
'passando Sh verrà ignorato Rng
'non passando argomenti verrà ricercata
'il range nel foglio attivo della cartella
'attiva contenente solo le celle contenenti
'un valore costante
'passando WithFormulas = True verranno
'considerate anche le celle contenenti una
'formula
Dim S As String, tS As String
Dim RE As Object
Dim maxR As Long, minR As Long
Dim maxC As Long, minC As Long
Dim V
'Verifico i primi due argomenti e setto
'il range di ricerca
If Sh Is Nothing Then
If Rng Is Nothing Then
Set Rng = [a1].Parent.UsedRange
End If
Set Sh = Rng.Parent
Else
Set Rng = Sh.UsedRange
End If
On Error Resume Next
'setto il range alle celle contenenti un valore
'costante
Set UsedRange_Value = Rng.SpecialCells( _
xlCellTypeConstants)
'Controllo il parametro opzionale
If WithFormulas Then
'aggiungo le celle contenenti le formule
If TypeName(UsedRange_Value) = "Nothing" Then
Set UsedRange_Value = _
Rng.SpecialCells(xlCellTypeFormulas, 23)
Else
Set UsedRange_Value = _
Union( _
UsedRange_Value, _
Rng.SpecialCells(xlCellTypeFormulas, 23))
End If
End If
On Error GoTo 0
'verifico che il range non sia vuoto
If TypeName(UsedRange_Value) = "Range" Then
'verifico se contiene più aree
If UsedRange_Value.Areas.Count > 1 Then
'recupero le coordinate per settare
'il range rettangolare
'ATTENZIONE!
'Comportamento non documentato di
'Address riferito a Range
'Rng.Address restituisce fino a 257
'caratteri
For Each V In UsedRange_Value
S = S & V. _
Address(True, True, xlR1C1)
Next
Set RE = CreateObject("vbscript.regexp")
RE.Global = True
RE.Pattern = "C\d+:,"
tS = RE.Replace(S, "")
RE.Pattern = "\d+"
maxR = RE.Execute(tS)(0)
minR = maxR
For Each V In RE.Execute(tS)
If V < minR Then
minR = V
ElseIf V > maxR Then
maxR = V
End If
Next
RE.Pattern = "R\d+:,"
tS = RE.Replace(S, "")
RE.Pattern = "\d+"
maxC = RE.Execute(tS)(0)
minC = maxC
For Each V In RE.Execute(tS)
If V < minC Then
minC = V
ElseIf V > maxC Then
maxC = V
End If
Next
Set UsedRange_Value = Sh.Range( _
Sh.Cells(minR, minC), _
Sh.Cells(maxR, maxC))
End If
End If
End Function
sabato 31 ottobre 2009
Via Taveggia - Corno di Medale (Lecco)

Funzioni ricorsive (VB)
Function N_Dim(arr As Variant, Optional ByVal l As Long = 1) As Long
On Error Resume Next
ArrayDims = LBound(arr, l)
If Err Then
N_Dim = l - 1
Else
N_Dim = N_Dim(arr, l + 1)
End If
End Function
Function Fact_If(ByVal N As Long) As Double
'Funzione ricorsiva per il calcolo del fattoriale
'di un numero
Fact_If = N
If N <> 1 Then Fact_If = Fact_If * Fact_If(N - 1)
End Function
Cavandoli Test (Excel - grafici a dispersione)
"vi giro un breve test per verificare la vostra preparazione riguardo ai grafici a dispersione in Excel" in allegato il file che potete scaricare a questo link
Link al file
venerdì 30 ottobre 2009
Ordinali Inglesi (Excel-VBA-VBSript)
Della serie ... Funzioni inutili ... ecco English_Ordinal O_R e Ordinals_R che trasforma un numero nel rispettivo ordinale inglese ... e Is_Ordinal che verifica se la stringa passata come argomento è o meno un ordinale inglese.
Il gioco stava nel *costringersi* ad usare le RegExp ... ma in questo caso forse hanno perso la gara ...
'in un modulo standard dell'editor vb di excel
'lanciare test
Sub test()
Dim i As Long
For i = 0 To 999
Cells(i + 1, 1) = English_Ordinal(i)
Cells(i + 1, 2) = Is_Ordinal(CStr(Cells(i + 1, 1)))
Next
End Sub
Function English_Ordinal(L As Long) As String
Dim re As Object
Dim S As String
S = L
Set re = CreateObject("vbscript.regexp")
re.Pattern = _
"((1[2-9]1)(2[2-9]2)(3[2-9]3)([04-9]1[0-9][2-9]0[2-9][4-9]))$"
S = re.Replace(S, ";$2st$3nd$4rd$5th")
re.Pattern = "(.*);.*?(\d+[a-z]{2}).*$"
English_Ordinal = re.Replace(S, "$1$2")
End Function
Public Function Is_Ordinal(S As String) As Boolean
Dim re As Object
S = "0" & S
Set re = CreateObject("VBScript.RegExp")
re.Pattern = "^\d*([02-9](1st2nd3rd[04-9]th))(1\dth)$"
Is_Ordinal = re.test(S)
End Function
Function Ordinals_R(l As Long) As String
Dim v, c As Long, i As Long
v = Array("th", "st", "nd", "rd")
c = Right(l, 1)
If Right(l, 2) - 10 <> c Then _
If c < 4 Then i = c
Ordinals_R = l & v(i)
End Function
Function O_R(l As Long) As String
'breve
Dim v, c As Long
v = Array("th", "st", "nd", "rd")
c = Right(l, 1)
O_R = l & v(IIf(Right(l, 2) - 10 = c, 0, IIf(c > 3, 0, c)))
End Function





























