[Excel VBA] Ricerche e Azioni Multiple su WorkBook

Descrizione :
Un mio esempio pratico su come impostare Ricerche e Azioni conseguenti su tutti i Fogli di un WorkBook.

+ Articolo :

In questo Articolo ho cercato di riunire alcune tecniche che fossero comuni più o meno a tutte le versioni di Excel e relativo VBA. Lo scopo è di eseguire una o più ricerche su tutti i Fogli di un WorkBook, utilizzando il più possibile Oggetti e Metodi base. Una ricerca Cella-per-Cella che sia in grado di eseguire più criteri contemporaneamente, e quindi più azioni da intraprendere, a seconda dei casi e degli esiti delle ricerche stesse.
Il tutto con il massimo controllo possibile, che spesso invece, utilizzando solo funzioni automatiche di Excel, viene perso.

L'esempio si basa sull'utilizzo di UserForm e di Funzioni parametrizzate definite a livello di Modulo.
Questa tecnica garantisce che il codice "di comando" sia eseguito ad un livello superiore rispetto ai moduli VBA dei singoli Fogli, e quindi senza rischio di conflitti o errori, anche in caso di selezioni.

Il WorkBook di esempio è semplice. Basta che contenga un certo numero di Fogli :

Foglio1
Foglio2
Foglio3
...
FoglioN

Su Foglio1 si inserisce un CommandButton ( del tipo ActiveX ) "cmd_formricerca".
In questo caso Foglio1 è escluso dalla ricerca perchè si presume che Foglio1 abbia il ruolo di "Foglio di Comando", e non contenga dati.

--> Codice cmd_formricerca :

Private Sub cmd_formricerca_Click()

    UserForm1.Show

End Sub

I rimanenti Fogli ( Foglio2 --> FoglioN ) conterranno dati organizzati in qualsivoglia struttura, come tabelle, righe o colonne separate da spazi, ecc...

Elemento principale dell'esempio è la UserForm1, da creare e disegnare all'interno dell'Editor VBA.

UserForm1 permetterà di :

1. Decidere se restringere o meno il campo di ricerca su ogni Foglio analizzato, ad un Range che sia effettivamente popolato da dati.

2. Decidere se la determinazione di tale Range-Dati vada fatta automaticamente o abbia dimensioni fisse predefinite.

3. Scegliere quali Fogli siano da escludere/includere nella ricerca.

4. Impostare una keyword e avviare la ricerca.

Struttura e funzionamento possono essere descritti con la seguente figura :

--> UserForm1 :
I controlli utilizzati sono di base e comuni a tutte le versioni di Excel VBA :
--> CheckBox : chk_autour
--> TextBox : txt_ricerca
--> CommandButton : cmd_selt
--> CommandButton : cmd_seln
--> CommandButton : cmd_cerca
--> ListBox : lst_fogli

--> Codice UserForm1 :

Private Const defaultStartC As Long = 1
Private Const defaultStartR As Long = 1
Private Const defaultEndC As Long = 50
Private Const defaultEndR As Long = 100

Private startC As Long
Private startR As Long
Private endC As Long
Private endR As Long

Private Sub cmd_selt_Click()

    Dim i As Integer
    For i = 0 To lst_fogli.ListCount - 1
        lst_fogli.Selected(i) = True
    Next i

End Sub

Private Sub cmd_seln_Click()

    Dim i As Integer
    For i = 0 To lst_fogli.ListCount - 1
        lst_fogli.Selected(i) = False
    Next i

End Sub

Private Sub UserForm_Initialize()

    Dim i As Integer
    With lst_fogli
        .ListStyle = fmListStyleOption
        .MultiSelect = fmMultiSelectMulti
        
        For i = 2 To ThisWorkbook.Worksheets.Count
            .AddItem (ThisWorkbook.Worksheets(i).Name)
            .Selected(.ListCount - 1) = True
        Next i
    End With

End Sub

Private Sub cmd_cerca_Click()

    If txt_ricerca.Text = "" Then
        MsgBox "La Text Ricerca non può essere vuota.", vbExclamation, "Errore"
        Exit Sub
    End If
    Dim strRicerca As String
    strRicerca = txt_ricerca.Text
    
    Dim c As Long
    Dim r As Long
    Dim msgr As VbMsgBoxResult
    
    Dim WS As Worksheet
    For i = 0 To lst_fogli.ListCount - 1
    
        If lst_fogli.Selected(i) = True Then
            Set WS = ThisWorkbook.Worksheets(lst_fogli.List(i))
           
            If chk_autour.Value = Checked Then
            
                '--------------------------------------------------
                'Qui il metodo di determinazione del Range Dati ...
                
                With WS.UsedRange
                    startC = .Column
                    endC = startC + .Columns.Count - 1
                    startR = .Row
                    endR = startR + .Rows.Count - 1
                End With
                
                '--------------------------------------------------
                
            Else
                startC = defaultStartC
                startR = defaultStartR
                endC = defaultEndC
                endR = defaultEndR
            End If
    
            For r = startR To endR
            
                For c = startC To endC
                
                    '----------------------------------------------------------
                    'Qui il blocco Condizioni / Azioni della cella corrente ...
                
                    'CondizioneAzione1
                    If CondizioneAzione1(WS, r, c, strRicerca) = True Then Exit Sub
                    
                    'CondizioneAzione2
                    CondizioneAzione2 WS, r, c, strRicerca
                    
                    '...
                    
                    'CondizioneAzioneN
                    
                    '...
                    
                    '----------------------------------------------------------
                
                Next c
                
            Next r
        End If
        
    Next i
   
    MsgBox "Ricerca terminata"

End Sub

I due "blocchi" di codice evidenziati e delimitati da commenti sono :
- Il blocco in cui inserire il metodo con cui il Range Dati viene definito : nell'esempio viene usato uno dei più immediati, che è .UsedRange dell'Oggetto WorkSheet, ma non è detto sia l'unico possibile.
- Il blocco in cui inserire le Condizioni da verificare e le Azioni conseguenti. Ogni Condizione/Azione corrisponde ad una Function o Sub parametrizzata e definita in un Modulo.

--> Codice Modulo :

Public Function CondizioneAzione1(ByVal WS As Worksheet, ByVal indiceR As Long, ByVal indiceC As Long, ByVal arg As String) As Boolean

    Dim msgr As VbMsgBoxResult
    If InStr(1, WS.Cells(indiceR, indiceC).Text, arg) > 0 Then
        WS.Select
        WS.Cells(indiceR, indiceC).Select
        msgr = MsgBox("Continuare la ricerca ?", vbYesNo, "Domanda")
        If msgr = vbNo Then
            MsgBox "Ricerca interrotta"
            CondizioneAzione1 = True
        Else
            CondizioneAzione1 = False
        End If
    End If

End Function

Public Sub CondizioneAzione2(ByVal WS As Worksheet, ByVal indiceR As Long, ByVal indiceC As Long, ByVal arg As String)

    Dim words() As String
    Dim word As Variant
    Dim FileNumber As Integer
    If InStr(1, WS.Cells(indiceR, indiceC).Text, arg) > 0 Then
        words = Split(WS.Cells(indiceR, indiceC).Text, " ")
        For Each word In words
            If IsNumeric(word) Then
                FileNumber = FreeFile
                Open ThisWorkbook.Path & "\report.txt" For Append As #FileNumber
                Print #FileNumber, Now & " - " & WS.Cells(indiceR, indiceC).Text
                Close #FileNumber
                Exit For
            End If
        Next word
    End If

End Sub

- Il primo è un esempio con una Function : la keyword viene cercata all'interno della cella ( Instr() ), perciò se la cella contiene la keyword anche come sottostringa, la ricerca da esito positivo.
In questo caso il valore Boolean restituito viene usato dal codice principale per decidere se continuare o meno con la ricerca.

- Il secondo esempio è una Sub : la keyword viene cercata allo stesso modo, ma se la ricerca da esito positivo viene eseguito un secondo test su tutte le parole della cella. Se una di esse è di tipo numerico, il risultato viene accodato in un file di testo.

Risulta abbastanza evidente come sia possibile estendere l'esempio a molti altri casi, con ricerche e operazioni difficilmente ( o per nulla ) ottenibili utilizzando le consuete procedure di ricerca...

+ Fine Articolo.

---

Un Click su "Mi Piace" è il modo migliore per ringraziare l'autore di questo articolo.

---

Continua a leggere »

Posted in: Excel VBA

[Excel VBA] DDE

Descrizione :
Un mio esempio pratico di utilizzo DDE da Excel VBA completo di generatore DDE ( VB6 ) per simulazioni.

+ Articolo :

Tempo fa ho creato questo esempio per un Forum, dopo un buon bombardamento di richieste da parte di utenti che ( purtroppo per loro ) devono avere a che fare con il DDE in Excel.

Per chi non sapesse di cosa sto parlando, DDE sta per "Dynamic Data Exchange" :
http://en.wikipedia.org/wiki/Dynamic_Data_Exchange

L'esempio simula un generatore di valori, che ho scritto in VB6, dal momento che VB6 ha un supporto nativo al DDE, e un progetto Excel che "ascolta" e registra i dati DDE in arrivo...
Chiaramente il punto su cui focalizzare l'attenzione è il lato-Excel della tecnica in quanto, nel caso reale, i dati arriveranno tipicamente da links remoti e non da un generatore/simulatore locale.

--> Listener_DDE.xls :
WorkBook Excel con il codice VBA essenziale per ricevere i dati DDE e inoltre per verificare se e quando i dati arrivano effettivamente.
L'essenziale per il Listener_DDE.xls è che ci sia un Foglio "DDE" e un Modulo VBA.
Su Foglio "DDE" ho inserito due CommandButton ( del tipo ActiveX, come sempre ), cmd_attivadde e cmd_disattivadde.
La loro funzione, come suggeriscono i nomi, è di attivare/disattivare l'ascolto di eventuali dati DDE in arrivo.

Il codice per il Foglio "DDE" è il seguente :

Private Sub cmd_attivadde_Click()

    ApplicaFormuleDDE

    Dim SorgentiDDE As Variant
    SorgentiDDE = ActiveWorkbook.LinkSources(xlOLELinks)
    Dim i As Integer
    If Not IsEmpty(SorgentiDDE) Then
        For i = 1 To UBound(SorgentiDDE)
            ActiveWorkbook.SetLinkOnData SorgentiDDE(i), "SuArrivoDatiDDE"
        Next i
    Else
        MsgBox "Nessuna Sorgente DDE Rilevata", vbExclamation, "Errore"
    End If

End Sub

Private Sub ApplicaFormuleDDE()

    'A1
    Sheets("DDE").Range("A1").FormulaR1C1 = "=GeneratoreValori_DDE|Form1!txt_dati01"

End Sub

Private Sub cmd_disattivadde_Click()

    'A1
    Sheets("DDE").Range("A1").FormulaR1C1 = ""

End Sub

"SuArrivoDatiDDE", come si nota è il nome della Routine, passato come stringa al Metodo SetLinkOnData.
Per questo ho creato un Modulo VBA e vi ho inserito il codice seguente :

Public Sub SuArrivoDatiDDE()

    Sheets("DDE").Range("B1").FormulaR1C1 = Sheets("DDE").Range("A1").Text

End Sub

La Public Sub SuArrivoDatiDDE() è la Routine in cui inserire le varie operazioni da eseguire sui dati DDE in arrivo.
In questo caso l'unica operazione eseguita è la copia dell'ultimo valore ricevuto da A1 a B1.
Ovviamente si possono inserire istruzioni di copia in righe e colonne, registrazione dati in file di testo, inserimenti a DB, grafici e quant'altro...

--> GeneratoreValori_DDE.exe :
L'applicazione VB6 che genera, in questo caso, una semplice serie di valori numerici crescenti, ed è costituita da una sola Form ed alcuni semplici controlli.
Un'immagine rende subito l'idea della struttura :

ComboBox --> cmb_secondi
CommandButton --> cmd_attivainviodde
CommandButton --> cmd_disattivainviodde
TextBox --> txt_dati01
Timer --> Timer1

Il codice completo del Progetto / Form VB6 di GeneratoreValori_DDE è il seguente :

'****************************************************
'***** Generatore Dati DDE Locale *******************
'***** MARCOGG 2011 *********************************
'****************************************************

' Impostare a Design le seguenti proprietà su Form1 :
' LinkMode = 1 - Source
' LinkTopic = Form1

Private num As Long

Private Sub cmb_secondi_Click()

    Timer1.Interval = CInt(cmb_secondi.Text) * 1000

End Sub

Private Sub Form_Load()

    Dim i As Integer
    For i = 1 To 60
        cmb_secondi.AddItem (i)
    Next i
    cmb_secondi.ListIndex = 0

End Sub

Private Sub cmd_attivainviodde_Click()

    cmb_secondi.Enabled = False
    Timer1.Enabled = True
    
End Sub

Private Sub cmd_disattivainviodde_Click()

    cmb_secondi.Enabled = True
    Timer1.Enabled = False
    
End Sub

Private Sub Timer1_Timer()

    num = num + 1
    txt_dati01.Text = num

End Sub

Naturalmente potrei avere un Generatore VB6 con N controlli che generano N valori, anche su tempi diversi e il WorkBook-Listener potrebbe avere le corrispondenti N Celle che li ricevono...

--> Run :

1. Lanciare in esecuzione GeneratoreValori_DDE.exe e Listener_DDE.xls.

2. Selezionare sul Generatore l'intervallo in secondi desiderato tra un invio dati DDE e il successivo, e poi Click su "Attiva Invio Dati DDE".

3. Sul WorkBook, Click su "Attiva Ascolto DDE".

A questo punto c'è tutto l'essenziale per approfondire ed eseguire test, e ovviamente per completarlo e complicarlo a piacere.

+ Fine Articolo.

---

Un Click su "Mi Piace" è il modo migliore per ringraziare l'autore di questo articolo.

---

Continua a leggere »

Posted in: Excel VBA

[Excel VBA] Insieme delle Parti

Descrizione :
Un metodo per l'estrazione dell'Insieme delle Parti da un Insieme dato di N elementi.

+ Articolo :

Dato un insieme S, per Insieme delle Parti di S si intende l'insieme di tutti i sottoinsiemi di S.
Questa collezione di insiemi viene anche detta insieme potenza di S o booleano di S.
Per esempio, se S è l'insieme {a,b,c}, allora la lista completa dei suoi sottoinsiemi risulta :

(l'insieme vuoto)
{a}
{b}
{c}
{a,b}
{a,c}
{b,c}
{a,b,c} che coincide con l'insieme stesso S

Detto N il numero di elementi di S, l'Insieme delle Parti di S contiene 2^N Elementi ( 2-elevato-N ).
Nel caso del presente esempio, gli elementi restituiti vengono disposti per colonne, e non viene considerato l'insieme vuoto, perciò vengono restituiti (N^2 - 1) Elementi.

Ammettiamo di avere un pulsante su Foglio1 e che Foglio2 sia il Foglio destinato a contenere i risultati dell'elaborazione.

--> Anzitutto la Function :

Public Function CombinazioniSemplici(ByVal arrayElementi As Variant, _
                                     ByVal dimensioneGruppo As Integer, _
                                     ByVal delimitatore As String) As Collection
 
    Dim LC As New Collection
    If UBound(arrayElementi) = 0 Then
        Set CombinazioniSemplici = LC
    End If
    If dimensioneGruppo = 0 Or dimensioneGruppo > UBound(arrayElementi) Then
        Set CombinazioniSemplici = LC
    End If
    Dim aP() As Integer
    ReDim aP(dimensioneGruppo - 1)
    Dim i As Integer
    For i = 0 To UBound(aP)
        aP(i) = i
    Next i
    Dim j As Integer
    Dim C As String
    Dim cnt As Integer
    Do
        C = ""
        For i = 0 To UBound(aP)
            If i < UBound(aP) Then
                C = C & arrayElementi(aP(i)) & delimitatore
            Else
                C = C & arrayElementi(aP(i))
            End If
        Next i
        LC.Add (C)
 
        cnt = 0
        For i = UBound(aP) To 0 Step -1
            If aP(i) = UBound(arrayElementi) - cnt Then
                cnt = cnt + 1
                If cnt = UBound(aP) + 1 Then Exit Do
            Else
                aP(i) = aP(i) + 1
                For j = 0 To UBound(aP)
                    If i < j Then aP(j) = aP(i) + (j - i)
                Next
                Exit For
            End If
        Next i
    Loop
 
    Set CombinazioniSemplici = LC
 
End Function

Questa Function è una versione modificata di altra mia Function generica per il Calcolo delle Combinazioni Semplici, disponibile qui :
http://marcoggblog.blogspot.com/2011/10/vb6-combinazioni-semplici-e-con.html

--> ESEMPIO di utilizzo con N numerici da 1 a 5 :

    Dim N As Integer
    N = 5 '<-- Numero elementi desiderato
 
    Dim delim As String
    delim = "/" '<-- delimitatore desiderato
 
    Dim WS As Worksheet 'Foglio risultati
    Set WS = ThisWorkbook.Worksheets("Foglio2")
    WS.Cells.ClearContents
 
    Dim A() As Variant
    ReDim A(N - 1)
    Dim i As Integer
    For i = 0 To UBound(A)
        A(i) = i + 1
    Next i
    Dim temp As Variant
    Dim j As Integer
    Dim K As Integer
    Dim CS As Collection
    Dim C As Long 'Indice di colonna
 
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
    Application.EnableEvents = False
 
    For K = N To 1 Step -1
 
        Set CS = CombinazioniSemplici(A, K, delim)
 
        For i = 1 To CS.Count
 
            C = C + 1
            temp = Split(CS(i), delim)
 
            For j = 0 To UBound(temp)
                WS.Cells(j + 1, C).FormulaR1C1 = temp(j)
            Next j
 
        Next i
 
    Next K
 
    Application.ScreenUpdating = True
    Application.Calculation = xlCalculationAutomatic
    Application.EnableEvents = True
 
    MsgBox "OK"

NOTE :

--> Gli elementi dell'insieme delle parti vengono correttamente disposti per colonne.

--> Un Foglio Excel 2007 / 2010 ha un max di 16384 Colonne ( 2^14 ), perciò, dato che il numero di elementi nell'insieme delle parti di un insieme di partenza di N elementi è di 2^N ( 2-elevato-N ), il limite sarà in questo caso di 2^14 = 16384.
Perciò, con questo particolare procedimento, N dovrà essere al massimo di 14 elementi.
Per N>14 il mio codice funziona allo stesso modo, ma bisognerà pensare ad un'altra disposizione dei risultati.

--> La mia Function funziona non solo con valori Integer nell'insieme, ma con qualsiasi valore, che siano numeri con o senza virgola, o stringhe.

--> ESEMPIO con 5 Stringhe :

    Dim N As Integer
    N = 5 '<-- Numero elementi desiderato
 
    Dim delim As String
    delim = "/" '<-- delimitatore desiderato
 
    Dim WS As Worksheet 'Foglio risultati
    Set WS = ThisWorkbook.Worksheets("Foglio2")
    WS.Cells.ClearContents
 
    Dim A() As Variant
    ReDim A(N - 1)
    Dim i As Integer
    For i = 0 To UBound(A)
        A(i) = Chr(i + 65) & (i + 1)
    Next i
    Dim temp As Variant
    Dim j As Integer
    Dim K As Integer
    Dim CS As Collection
    Dim C As Long 'Indice di colonna
 
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
    Application.EnableEvents = False
 
    For K = N To 1 Step -1
 
        Set CS = CombinazioniSemplici(A, K, delim)
 
        For i = 1 To CS.Count
 
            C = C + 1
            temp = Split(CS(i), delim)
 
            For j = 0 To UBound(temp)
                WS.Cells(j + 1, C).FormulaR1C1 = temp(j)
            Next j
 
        Next i
 
    Next K
 
    Application.ScreenUpdating = True
    Application.Calculation = xlCalculationAutomatic
    Application.EnableEvents = True
 
    MsgBox "OK"

+ Fine Articolo.

---

Un Click su "Mi Piace" è il modo migliore per ringraziare l'autore di questo articolo.

---

Continua a leggere »

Posted in: Excel VBA

[Excel VBA] CopyFromRecordset

Descrizione :
Semplice tecnica VBA per importare velocemente dati da un DB Access in un Foglio Excel.

+ Articolo :

Il Metodo CopyFromRecordset è disponiblie a partire da Excel 2003.

Di seguito mostro 3 varianti per file Access .mdb : le prime due usano CopyFromRecordset, mentre l'ultima un Loop diretto sul Recordset ottenuto.

N.B.: E' necessario aggiungere nell'Editor VBA ( menu Strumenti / Riferimenti ), se già non presente nel Progetto VBA corrente, un Riferimento alla libreria :
Microsoft DAO 3.6 Object Library
Nel caso di questo esempio ( Excel + Access 2003 ), la versione è la 3.6.

Nell'esempio il DB Access è nella stessa cartella del file Excel.

--> Variante 1 :
E' il sistema più immediato. Il Recordset viene caricato direttamente da una Tabella o Stored Query di Access :

    Dim percorso As String 'Percorso File DB
    percorso = ThisWorkbook.Path & "\"
 
    Dim nomeDb As String 'Nome File DB
    nomeDb = "nomeDB.mdb"
 
    Dim nomeTabQry As String 'Nome Tabella o Stored Query Access
    nomeTabQry = "nomeTabella"
 
    Dim DB As Database
    Dim RS As Recordset
    Set DB = OpenDatabase(percorso & nomeDb)
    Set RS = DB.OpenRecordset(nomeTabQry)
 
    'Intestazione Colonne
    Dim i As Integer
    For i = 0 To RS.Fields.Count - 1
        ThisWorkbook.Worksheets("Foglio1").Cells(1, i + 1).FormulaR1C1 = RS.Fields(i).Name
    Next i
 
    'Tabella Dati
    ThisWorkbook.Worksheets("Foglio1").Range("A2").CopyFromRecordset RS
 
    Set RS = Nothing
    DB.Close
    Set DB = Nothing

--> Variante 2 :
Il Recordset viene caricato con una Query definita come stringa in Excel :

    Dim percorso As String 'Percorso File DB
    percorso = ThisWorkbook.Path & "\"
 
    Dim nomeDb As String 'Nome File DB
    nomeDb = "nomeDB.mdb"
 
    Dim strSql As String 'Stringa Sql
    strSql = "SELECT * FROM nomeTabella"
 
    Dim DB As Database
    Dim RS As Recordset
    Set DB = OpenDatabase(percorso & nomeDb)
    Set RS = DB.OpenRecordset(strSql)
 
    'Intestazione Colonne
    Dim i As Integer
    For i = 0 To RS.Fields.Count - 1
        ThisWorkbook.Worksheets("Foglio1").Cells(1, i + 1).FormulaR1C1 = RS.Fields(i).Name
    Next i
 
    'Tabella Dati
    ThisWorkbook.Worksheets("Foglio1").Range("A2").CopyFromRecordset RS
 
    Set RS = Nothing
    DB.Close
    Set DB = Nothing

--> Variante 3 :
Voglio copiare le righe del Recordset intervallandole con righe vuote ( un esempio su come avere maggior controllo sul RS ottenuto ).
Non uso più CopyFromRecordset, ma un Loop :

    Dim percorso As String 'Percorso File DB
    percorso = ThisWorkbook.Path & "\"
 
    Dim nomeDb As String 'Nome File DB
    nomeDb = "nomeDB.mdb"
 
    Dim nomeTabQry As String 'Nome Tabella o Stored Query Access
    nomeTabQry = "nomeTabella"
 
    Dim DB As Database
    Dim RS As Recordset
    Set DB = OpenDatabase(percorso & nomeDb)
    Set RS = DB.OpenRecordset(nomeTabQry)
 
    'Intestazione Colonne
    Dim i As Integer
    For i = 0 To RS.Fields.Count - 1
        ThisWorkbook.Worksheets("Foglio1").Cells(1, i + 1).FormulaR1C1 = RS.Fields(i).Name
    Next i
 
    'Tabella Dati
    Dim r As Long
    r = 3
    If Not RS.BOF Then RS.MoveFirst
    While Not RS.EOF
        For i = 0 To RS.Fields.Count - 1
            ThisWorkbook.Worksheets("Foglio1").Cells(r, i + 1).FormulaR1C1 = RS.Fields(i).Value
        Next i
        RS.MoveNext
        r = r + 2
    Wend
 
    Set RS = Nothing
    DB.Close
    Set DB = Nothing

In presenza di file di database .accdb, meglio affidarsi ad ADODB ( che può essere valida alternativa anche per i casi precedenti ), quindi in questo caso andrà aggiunto un RIF. alla Libreria :
Microsoft ActiveX Data Objects 2.8 Library

--> Variante 1 ( con Access 2007 ) :

    Dim percorso As String 'Percorso File DB
    percorso = ThisWorkbook.Path & "\"
 
    Dim nomeDb As String 'Nome File DB
    nomeDb = "nomeDB.accdb"
 
    Dim nomeTabQry As String 'Nome Tabella o Stored Query Access
    nomeTabQry = "nomeTabella"
 
    Dim CN As ADODB.Connection
    Dim RS As ADODB.Recordset
    Set CN = New ADODB.Connection
    CN.ConnectionString = "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & _
                           percorso & nomeDb & ";Persist Security Info=False;"
    CN.Open
    Set RS = New ADODB.Recordset
    RS.Open nomeTabQry, CN, adOpenKeyset, adLockReadOnly, adCmdTable
 
    'Intestazione Colonne
    Dim i As Integer
    For i = 0 To RS.Fields.Count - 1
        ThisWorkbook.Worksheets("Foglio1").Cells(1, i + 1).FormulaR1C1 = RS.Fields(i).Name
    Next i
 
    'Tabella Dati
    ThisWorkbook.Worksheets("Foglio1").Range("A2").CopyFromRecordset RS
 
    CN.Close
    Set CN = Nothing
    Set RS = Nothing

Varianti 2 e 3 per .accdb, analogamente ai casi visti per file .mdb.

+ Fine Articolo.

---

Un Click su "Mi Piace" è il modo migliore per ringraziare l'autore di questo articolo.

---

Continua a leggere »

Posted in: Excel VBA

[Excel VBA] Importazione WorkSheets da files esterni

Descrizione :
Una tecnica per automatizzare l'importazione su singolo file Excel di fogli da files esterni e da varie cartelle.

+ Articolo :

E' necessario predisporre un WorkBook di "comando", che esegue il codice necessario per la creazione di un nuovo WorkBook di "destinazione", che conterrà, alla fine del processo, N Fogli presi da N Files esterni che si trovano in percorsi forniti come array di percorsi alla routine del comando stesso.
Per semplicità, nell'esempio seguente viene mostrato come importare il primo Foglio di ciascuno dei files Excel trovati, in ciascuna delle directory inserite nell'array.

Il File "Comando.xls" ha un solo Foglio "Foglio1" con un CommandButton.

All'esecuzione il File Comando copia in se stesso tutti i Fogli di un certo indice ( nel nostro caso il Foglio a indice 1 ) trovati nei Files contenuti in tutti i percorsi di ricerca forniti. Alla fine del processo il file Comando salva se stesso con un nome predefinito per il File di Output ed elimina il Foglio che contiene la routine di creazione.
In questo modo evito di gestire la creazione di un terzo file e l'inserimento dei Fogli sullo stesso, che aggiungerebbe all'operazione una serie di passaggi inutili, inoltre il salvataggio permette di chiudere automaticamente il file Comando senza rischi di sovrascrittura...

N.B.: Aggiungere un Rif. alla libreria "Microsoft Scripting Runtime".

--> Codice per il pulsante su Comando.xls :

    'Aggiungere RIF.: Microsoft Scripting Runtime
 
    Dim FSO As New Scripting.FileSystemObject
 
    Dim percorsi() As Variant
    percorsi = Array(ThisWorkbook.Path & "\Cartella1\", ThisWorkbook.Path & "\Cartella2\")
    Dim percorsoDest As String
    percorsoDest = ThisWorkbook.Path & "\"
 
    Dim nomeFileDest As String
    nomeFileDest = "Destinazione.xls"
    If FSO.FileExists(percorsoDest & nomeFileDest) = True Then
        FSO.DeleteFile percorsoDest & nomeFileDest
    End If
 
    Dim fd As Folder
    Dim f As File
    Dim nomeFile As String
    Dim nomeFoglio As String
    Dim WB As Workbook
    Dim WS As Worksheet
    Dim cnt As Integer
    cnt = 1
 
    Application.ScreenUpdating = False
    'Application.Visible = False
 
    For Each percorso In percorsi
        Set fd = FSO.GetFolder(percorso)
        For Each f In fd.Files
            'Controllo sulle estensioni dei file da importare...
            If FSO.GetExtensionName(f.Path) = "xls" Then ' OR < altre estensioni Excel >...
                nomeFile = f.Name
                nomeFoglio = cnt & "_" & Left(nomeFile, Len(nomeFile) - Len(FSO.GetExtensionName(f.Path)) - 1)
 
                Set WB = Application.Workbooks.Open(percorso & nomeFile)
                Set WS = WB.Worksheets(1)
                WS.Name = nomeFoglio
                WS.Copy after:=ThisWorkbook.Worksheets(ThisWorkbook.Worksheets.Count)
 
                WB.Close False
                Set WB = Nothing
                cnt = cnt + 1
            End If
        Next f
    Next percorso
 
    Application.ScreenUpdating = True
    'Application.Visible = True
 
    ThisWorkbook.SaveAs percorsoDest & nomeFileDest
    MsgBox "Fogli Importati.", vbInformation, "OK"
 
    Application.DisplayAlerts = False
    ThisWorkbook.Worksheets(1).Delete

Alcune note :

1. Come spesso accade, gran parte dell'apparente laboriosità nell'esecuzione di un codice VBA dipende principalmente da questioni di refresh grafico. Allo scopo di rendere più snello il processo è presente una riga con Application.ScreenUpdating = False.
Ho volutamente lasciato anche Application.Visible = False, commentato, da usarsi in alternativa al primo, con l'effetto di rendere l'esecuzione ancora più veloce.
Unico inconveniente è che su importazioni lunghe l'utente vedrebbe sparire la finestra di Excel per un certo tempo e potrebbe iniziare... a preoccuparsi, perciò fate vobis.

2. E' possibile inserire altre estensioni ( senza il punto ) sulla riga di controllo delle estensioni da prendere in esame, mettendole in OR tra loro :

'Controllo sulle estensioni dei file da importare...
If FSO.GetExtensionName(f.Path) = "xls" Then ' OR < altre estensioni Excel >...

3. Il processo nomina in automatico ogni nuovo foglio importato con un numero progressivo + il nome del file di origine. Ogni modifica al metodo con cui nominare i Fogli va fatto qui :

...
nomeFoglio = cnt & "_" & Left(nomeFile, Len(nomeFile) - Len(FSO.GetExtensionName(f.Path)) - 1)

4. La riga di eliminazione del Foglio codice, se desiderata, deve sempre essere l'ultima ad essere eseguita :

...
...
ThisWorkbook.Worksheets(1).Delete
 
End Sub

+ Fine Articolo.

---

Un Click su "Mi Piace" è il modo migliore per ringraziare l'autore di questo articolo.

---

Continua a leggere »

Posted in: Excel VBA

[Excel VBA] Matrice con Valori Random

Descrizione :
Come generare una Matrice quadrata con valori Random su Foglio Excel. 

+ Articolo :
Nell'esempio seguente viene generata una Matrice quadrata con valori binari [0,1], con un numero prefissato di valori "1", e con tutti "0" sulla diagonale. Il codice è abbastanza semplice e lineare da consentire facilmente qualsiasi modifica o adattamento.

Poniamo che la mia matrice 15x15 debba occupare il Range [N1:AB15], e che il numero desiderato di numeri 1 da inserire sia 20 :

    Dim WB As Worksheet 'Imposta Foglio
    Set WB = Worksheets("Foglio1")
    Dim C As Range 'Imposta Cella iniziale : angolo alto-sinistro matrice
    Set C = WB.Range("N1")
    Dim m As Integer 'Imposta dimensione matrice (quadrata)
    m = 15
    Dim num1 As Integer 'Imposta numeri 1 desiderati in matrice
    num1 = 20
    
    Dim cnt1 As Integer
    Dim indMinR As Long 'Indice minimo riga
    indMinR = C.Row
    Dim indMinC As Long 'Indice minimo colonna
    indMinC = C.Column
    Dim indMaxR As Long 'Indice max riga
    indMaxR = C.Offset(m - 1, 0).Row
    Dim indMaxC As Long 'Indice max colonna
    indMaxC = C.Offset(0, m - 1).Column
    Dim indR As Long
    Dim indC As Long
    
    WB.Range(C, C.Offset(m - 1, m - 1)) = 0
    WB.Range(C, C.Offset(m - 1, m - 1)).Interior.Color = vbWhite
       
    Do
        
        indR = RandomizzaIntero(indMinR, indMaxR)
        indC = RandomizzaIntero(indMinC, indMaxC)
        
        If WB.Cells(indR, indC).Value = 0 And (indR - C.Row) <> (indC - C.Column) Then
            WB.Cells(indR, indC).Value = 1
            WB.Cells(indR, indC).Interior.Color = vbGreen
            cnt1 = cnt1 + 1
        End If
               
    Loop Until cnt1 = num1

dove RandomizzaIntero() è la semplice Function :

Public Function RandomizzaIntero(ByVal min As Long, ByVal max As Long) As Long

    RandomizzaIntero = Int((max - min + 1) * Rnd + min)

End Function

min e max sono argomenti che permettono di selezionare un range entro cui la Function dovrà restituire il numero Long Random.
In soldoni, un RandomizzaIntero( 2, 4 ) restituirà {2,3,4} ( perciò estremi inclusi ).
In caso di argomenti invertiti, invece un RandomizzaIntero( 6, 3 ) restituirà un range di valori con estremi esclusi : {4,5}.

Il risultato sarà di questo tipo :

In pratica si Randomizza l'indirizzo di cella all'interno del Range desiderato, il che garantisce una buona distribuzione "casuale" dei valori.

Con "C" scelgo la cella da cui inizia la matrice ( cella in alto a sinistra - in questo caso N1 )
e con "m" la dimensione ( la matrice quadrata avrà m righe x m colonne ).
Offset restituisce un oggetto Range che rappresenta un intervallo distanziato dall'intervallo specificato.
Se applicato ad una cella restituisce la cella che si ottiene spostandosi dalla cella di partenza di un numero di celle defnito dai parametri (RowOffset, ColumnOffset).

+ Fine Articolo.

---

Un Click su "Mi Piace" è il modo migliore per ringraziare l'autore di questo articolo.

---

Continua a leggere »

Posted in: Excel VBA