"Spacchettare" un foglio excel su vari file.

[Scossa]

Prendo spunto da una richiesta di aiuto postata su mpioe per
affrontare un problema ricorrente.

Dato un foglio Excel contenente dei dati con una struttura
riconducibile a questa:

A B C
|-------------------|------------------|------------|
1| chiave | dato1 | dato2 |
2| ALFA | 10000 | 1700 |
3| ALFA | 21000 | 900 |
4| ALFA | 32000 | 100 |
5| BETA | 42000 | 4500 |
6| BETA | 51000 | 5400 |
7| BETA | 61000 | 4300 |
8| BETA | 71000 | 3400 |
9| GAMMA | 71000 | 1200 |
10| GAMMA | 115000 | 2300 |
11| GAMMA | 3000 | 4300 |
12| GAMMA | 50000 | 2100 |
13| DELTA | 2000 | 3300 |
14| DELTA | 12000 | 1100 |
15| ZETA | 11000 | 4600 |
16| ZETA | 7000 | 3500 |
17| EPSILON | 8000 | 4500 |
18| totale | 567000 | 47200 |

vogliamo creare per ogni valore (univocamente considerato) in
*chiave*, un file contenente una copia del foglio con i soli dati
relativi al valore della propria *chiave*.

Nell'esempio, vogliamo creare 6 file:

- un file ALFA.xls che conterrà
A B C
|-------------|--------------|-------|
1| chiave | dato1 | dato2 |
2| ALFA | 10000 | 1700 |
3| ALFA | 21000 | 900 |
4| ALFA | 32000 | 100 |
5| totale | 63000 | 2700 |

un file BETA.xls che conterrà:
A B C
|-------------|--------------|-------|
1| chiave | dato1 | dato2 |
2| BETA | 42000 | 4500 |
3| BETA | 51000 | 5400 |
4| BETA | 61000 | 4300 |
5| BETA | 71000 | 3400 |
6| totale | 225000 | 17600 |


..... etc etc, fino al file ZETA che conterrà:
A B C
|-------------|--------------|-------|
1| chiave | dato1 | dato2 |
2| EPSILON | 8000 | 4500 |
3| totale | 8000 | 4500 |


Per poche righe e pochi valori di *chiave* si può risolvere
manualmente con "sposta o copia" (click dx sul tab del foglio) facendo
una copia su una nuova cartella ed eliminando da questa tutte le righe
dei dati che non appartengono alla chiave.
Quindi si salva il file col nome della chiave, lo si chiude e si
ripete l'operazione per le altre chiavi.

Ma se questo lavoro deve essere eseguito su un file di 20.000 righe
con qualche decina di valori di *chiave* la cosa oltre che noiosa
diventa lunga e possibile fonte di errori.

Ho quindi realizzato un codice piuttosto semplice che esegue queste
operazioni automaticamente.
Dato il file illustrato sopra, selezioneremo le celle A2:A17 e
lanceremo la macro SpacchettaInFile().
Ci verrà fatta scegliere la directory dove "depositare" i file creati
e, poichè è fondamentale che i valori uguali delle chiavi siano
consecutivi, ci verrà chiesto se ordinare i dati; verrà quindi chiesta
conferma dell'esecuzione.

N.B.: non è indispensabile che il valore delle chiavi sia la prima
colonna, nè che sia il primo campo di ordinamento, l'importante è che
i valori uguali siano consecutivi.

Ho depositato nell'apposito spazio un piccolo file di esempio con il
codice relativo.

Le performance in termine di velocità non sono eccezionali: partendo
da un file con 21.760 righe di dati per 25 valori di *chiave*, crea
(sul mio PC) i 25 file in circa 50 secondi (la routine che ho scritto
per mio uso quotidiano - ben più complessa e flessibile, impiega circa
11 secondi per lo stesso lavoro ma ha una "logica" diversa).

Pertanto questo vuole essere uno spunto per chi vuole cimentarsi a
migliorare il codice o anche solo ad avanzare delle critiche
costruttive :-)

Il sasso l'ho lanciato!

Bye!
Scossa

[Scossa]

> Ho depositato nell'apposito spazio un piccolo file di esempio con il
> codice relativo.

il link:
http://05106688347636842813-a-g.googlegroups.com/web/SpacchettaInFile.xls

Bye!
Scossa

[roberto mensa]

Domanda: se il file esiste già cosa si vuole fare? Ciao r

Il 13/07/10, Scossa<scos...@gmail.com> ha scritto:

[Scossa]

> Domanda: se il file esiste già cosa si vuole fare? Ciao r
>

Sovrascrivere!! senza ombra di dubbio e senza avviso :-))

Si può comunque modificare il codice per cambaire il nome del file
ma ..... lascio a te il compito, visto che hai notevole dimestichezza
col file-system :-))

Bye!
Scossa

[roberto mensa]

Aggiungere un nuovo foglio no?

Il 13/07/10, Scossa<scos...@gmail.com> ha scritto:
>

[roberto mensa]

Già che sono al cellulare mi chiarisco le idee, eventuali caratteri
non accettati nel nome del file, li posso spazzare via?

Il 13/07/10, roberto mensa<robb...@gmail.com> ha scritto:

[Scossa]

On 13 Lug, 22:04, roberto mensa <robb....@gmail.com> wrote:
> Già che sono al cellulare mi chiarisco le idee, eventuali caratteri
> non accettati nel nome del file, li posso spazzare via?

Sostituirli col carattere non accentato: ò -> o


Bye!
Scossa

[Scossa]

On 13 Lug, 21:58, roberto mensa <robb....@gmail.com> wrote:
> Aggiungere un nuovo foglio no?

Non saprei. Per come lo uso io, a me va bene che venga sovrascritto,
però si potrebbe offrire una scelta all'utente...

Bye!
Scossa

[roberto mensa]

senti al volo ... solo per vedere se ti piace l'idea ... poi eventualmente si sviluppa il tutto ...

 

ti posizioni sulla tua tabella e lanci la macro ...

 

Sub Crea_file()
Dim PC As Excel.PivotCache
Dim PT As Excel.PivotTable
Dim rng1 As Excel.Range
Dim Rng2 As Excel.Range, Rng3 As Excel.Range
Dim PvtF As Excel.PivotField
Dim s As String, s2 As String
Dim d As Double

d = Timer
Set rng1 = ActiveCell.CurrentRegion
s2 = rng1(1).Value
Set Rng2 = Nuovo_Range(ActiveWorkbook, "ShPivot")
s = "pvt" & Rng2.Parent.Name
Set PC = ActiveWorkbook.PivotCaches.Add _
    (SourceType:=xlDatabase, SourceData:=rng1)
Set PT = PC.CreatePivotTable _
        (TableDestination:=Rng2.Offset(2), _
        TableName:=s)
With PT
    .AddDataField .PivotFields(s2)
    .PivotFields(s2).Orientation = xlRowField
    Set PvtF = .PivotFields(s2)
    Set rng1 = PvtF.DataRange
    For Each Rng2 In rng1
        Rng2.Offset(0, 1).ShowDetail = True
        Set Rng3 = ActiveSheet.[a1]
        Rng3.Parent.Copy
        ActiveWorkbook.Close True, _
            ThisWorkbook.Path & _
            Application.PathSeparator & _
            Rng2.Value & ".xls"
        Application.DisplayAlerts = False
        Rng3.Parent.Delete
        Application.DisplayAlerts = True
    Next
End With
MsgBox Timer - d
End Sub

 

ripeto solo per provare una via diversa ...

i file vengono per ora salvati nella directory di thisworkbook .... quindi provalo su un file salvato ...

ciao

a domani

r

 

[r]

On 14 Lug, 00:12, roberto mensa <robb....@gmail.com> wrote:

avevo dimenticato un pezzo ... domani eventualmente la perfeziono,
intanto riposto tutta la procedura:

Function Nuovo_Range( _
Wb As Excel.Workbook, _
Optional Nome_base As _
String = "Foglio") As Excel.Range
'di Roberto Mensa - Nick r


'restituisce la cella A1 di un nuovo foglio
'il nuovo foglio viene rinominato in base
'all'argomento Nome_base


Dim b
Set Nuovo_Range = Wb.Worksheets.Add.Range("A1")


Application.ScreenUpdating = False
On Error Resume Next
Do
Err.Clear
Nuovo_Range.Parent.Name = Nome_base & b
b = b + 1
Loop While Err
Application.ScreenUpdating = True


End Function

[Scossa]

On 14 Lug, 00:12, roberto mensa <robb....@gmail.com> wrote:

> tutta da perfezionare ... è solo uno spunto per vedere se l'idea
> piace ...
> posizionarsi sulla tabella e lanciare la macro ... i file verranno
> creati nella directory di thisworkbook

Ciao Rob,

l'idea è interessante, soprattutto per la velocità di esecuzione (10
secondi per i 25 file dal foglio di 21.760 righe di cui parlavo, pari
al tempo della mia routine "veloce") però .... ha un grosso difetto:

non riproduce la struttura del foglio originale!

Se guardi il mio file di esempio noterai che:
- la prima riga è vuota (ma potrebbe avere una descrizione e/o un
logo);
- la seconda riga contiene nella colonna B un subtotale dei relativi
dati;
- la terza riga è vuota;
- l'ultima riga (28) contiene nelle colonne A:D la rispettiva somma
delle righe dei dati.

Tutto questo con la tua routine non viene replicato.

Riguardo i tempi non entusiasmanti della routine SpacchettaInFile()
(su fogli con numerosi dati: nell'esempio delle 21.000 righe siamo a
oltre 3 Mega) è dovuto al metodo usato: per ogni chiave copia l'intero
foglio e poi elimina le righe non di pertinenza.

Pensavo allora di copiare il foglio coi dati sullo stesso workbook di
origine ed eliminare su questo +una sola volta per tutte+ le righe
dei dati, quindi copiare questo folgio "quasi" vuoto per ogni valore
di chiave su un nuovo file e quindi in questo copiare i dati del range
di pertinenza.

Stasera ci penserò.

Bye!
Scossa

[roberto mensa]

Il giorno 14 luglio 2010 09.06, Scossa <scos...@gmail.com> ha scritto:

On 14 Lug, 00:12, roberto mensa <robb....@gmail.com> wrote:

> tutta da perfezionare ... è solo uno spunto per vedere se l'idea
> piace ...
> posizionarsi sulla tabella e lanciare la macro ... i file verranno
> creati nella directory di thisworkbook

Ciao Rob,

l'idea è interessante,

 

[...]

 

si immaginavo che non fosse proprio quello che volevi fare tu ... però ascolta visto che trovi interessante la soluzione (e io l'ho proposta perchè è un modo particolare di risolvere le pivot non vengono molto utilizzate quando si scrive codice) pensavo ... io continuo seguendo questa strada ... abbellisco un po' e miglioro il tutto così possiamo proporre due soluzioni diverse che rispondono a esigenze diverse ... che ne dici?

ciao

r

 

[Scossa]

On 14 Lug, 12:21, roberto mensa <robb....@gmail.com> wrote:

> quando si scrive codice) pensavo ... io continuo seguendo questa strada ...
> abbellisco un po' e miglioro il tutto così possiamo proporre due soluzioni
> diverse che rispondono a esigenze diverse ... che ne dici?

Ciao rob,
ottimo.

Io intanto ho modificato il codice della mia, riducendo il tempo di
esecuzione di quasi il 50%:
sul solito file di 21000 righe impiega ora meno di 30 secondi conto i
50 della precedente.

Il fatto è che ho dovuto fare un compromesso: per non perdere i
riferimenti nelle formule e nei nomi non ho potuto eliminare tutte le
righe dei dati, ma ho dovuto tenere la prima e l'ultima.
Creo quindi la copia del foglio che contiene queste due righe di dati
(ora consecutive) e tra queste due con in ciclo for inseririsco tante
righe nuove quante sono le righe del range da copiare (-2); quindi
copio il range relativo.
Questo ciclo for purtroppo rallenta comunque la procedura.
Del resto se eliminassi tutte le righe mi troverei le eventuali
formule e gli eventuali nomi con l'errore #RIF!.

Questo il file:
http://groups.google.it/group/excel_vba_free/web/SpacchettaInFile3.xls?hl=it

Ho eliminato il precedente.

Bye!
Scossa

[r]

On 14 Lug, 19:36, Scossa <scossa...@gmail.com> wrote:
> On 14 Lug, 12:21, roberto mensa <robb....@gmail.com> wrote:
>
> > quando si scrive codice) pensavo ... io continuo seguendo questa strada ...
> > abbellisco un po' e miglioro il tutto così possiamo proporre due soluzioni
> > diverse che rispondono a esigenze diverse ... che ne dici?
>
> Ciao rob,
> ottimo.

ok allora ...

>
> Io intanto ho modificato il codice della mia, riducendo il tempo di
> esecuzione di quasi il 50%:
> sul solito file di 21000 righe impiega ora meno di 30 secondi conto i
> 50 della precedente.
>
> Il fatto è che ho dovuto fare un compromesso: per non perdere i
> riferimenti nelle formule e nei nomi non ho potuto eliminare tutte le
> righe dei dati, ma ho dovuto tenere la prima e l'ultima.
> Creo quindi la copia del foglio che contiene queste due righe di dati
> (ora consecutive) e tra queste due con in ciclo for inseririsco tante
> righe nuove quante sono le righe del range da copiare (-2); quindi
> copio il range relativo.
> Questo ciclo for purtroppo rallenta comunque la procedura.
> Del resto se eliminassi tutte le righe mi troverei le eventuali
> formule e gli eventuali nomi con l'errore #RIF!.

devo provare ... ti saprò dire ... ma credo che la situazione sia
piuttosto complessa ... un conto è replicare una struttura definita e
definitiva ... un altro è capire cosa c'è nel foglio e riprodurlo ...
il fatto per es. che si siano dei subtotali o delle formule è molto
soggettivo ... se la struttura del foglio fosse definita e
definibile ...
saluti
r


>
> Questo il file:http://groups.google.it/group/excel_vba_free/web/SpacchettaInFile3.xl...

[Scossa]

On 14 Lug, 23:59, r <robb....@gmail.com> wrote:
>
> devo provare ... ti saprò dire ... ma credo che la situazione sia
> piuttosto complessa ... un conto è replicare una struttura definita e
> definitiva ... un altro è capire cosa c'è nel foglio e riprodurlo ...

Ciao rob,

Ho modificato la procedura SpacchettaInFile(), eliminando il ciclo for
per l'inserimento delle righe.
Ora genera i 25 file dal solito foglio di 21.760 righe in 14 secondi!!
mantendo del tutto il foglio di origine(immagini comprese).

In pratica ho scritto una function che, dati due range, di cui il
secondo è un sottoinsieme del primo, restituisce una stringa con
l'indirizzo delle aree del primo range che non sono incluse nel
secondo:

per esempio

NotIntersect( Range("A5:A27"), Range("A15:A20"))
restituisce "$A$5:$A$14,$A$21:$A$27"

NotIntersect( Range("A5:A27"), Range("A5:A12")))
restituisce "$A$13:$A$27"


Quindi, usando come matrice una copia del foglio origine ma con le
rige dati vuote (.clearcontents), lascio sul foglio di destinazione n
righe quante sono le righe nel foglio di origne per quella *chiave* e
quindi le copio.

Questa è la function, magari è migliorabile, ho preferito usare
variabili stringa anzichè range ma altre soluzioni se semplificano il
codice sono gradite:


'-------------------------------
' Procedure : NotIntersect
' Author : Scossa
' Date : 15/07/2010
'-------------------------------
Public Function NotIntersect(RngBig As Range, RngSmall As Range) As
String

Dim srngBTop As String, srngSTop As String
Dim srngBBtm As String, srngSBtm As String
Dim sRng1Top As String, sRng1Btm As String
Dim sRng2Top As String, sRng2Btm As String
Dim nRowsB As Long, nRowsS As Long
Dim nColsB As Long, nColsS As Long
Dim sRet_ As String


nColsB = RngBig.Columns.Count
nColsS = RngSmall.Columns.Count
nRowsB = RngBig.Rows.Count
nRowsS = RngSmall.Rows.Count
srngBTop = RngBig.Cells(1, 1).Address
srngSTop = RngSmall.Cells(1, 1).Address
srngBBtm = RngBig.Cells(nRowsB, nColsB).Address
srngSBtm = RngSmall.Cells(nRowsS, nColsS).Address


If (RngBig.Column = RngSmall.Column) And _
(nRowsB >= nRowsS) And _
(nColsB = nColsS) And _
Not RngBig.Address = RngSmall.Address Then

sRng1Top = RngBig.Cells(1, 1).Address
sRng1Btm = RngSmall.Cells(1, nColsS).Offset(-1).Address
sRng2Top = RngSmall.Cells(nRowsS, 1).Offset(1).Address
sRng2Btm = RngBig.Cells(nRowsB, nColsB).Address

If srngBTop = srngSTop Then
sRet_ = sRng2Top & ":" & sRng2Btm
ElseIf srngBBtm = srngSBtm Then
sRet_ = sRng1Top & ":" & sRng1Btm
Else
sRet_ = (sRng1Top & ":" & sRng1Btm & "," & sRng2Top & ":" &
sRng2Btm)
End If
Else

sRet_ = ""

End If

NotIntersect = sRet_

End Function
'------------------------------

'Questo un esempio di utilizzo:

Public Sub test()
Dim rngDif As Range
Dim rng1 As Range
Dim rng2 As Range
Dim srngDif As String

Set rng1 = Range("A5:B27")
Set rng2 = Range("A13:B20")
srngDif = NotIntersect(rng1, rng2)
If srngDif <> "" Then
Set rngDif = Range(srngDif)
MsgBox "range sopra: " & rngDif.Areas(1).Address & vbCrLf & _
"range sotto: " & rngDif.Areas(2).Address

Else
MsgBox "range vuoto"
End If

set rng1 = nothing
set rng2 = nothing
set rngDif = nothing

End Sub
'----------------


Bye!
Scossa

[Scossa]

On 15 Lug, 14:18, Scossa <scossa...@gmail.com> wrote:
> On 14 Lug, 23:59, r <robb....@gmail.com> wrote:
>
> 'Questo un esempio di utilizzo:

Più chiaro così:

'---------------

Public Sub test()
Dim rngDif As Range
Dim rng1 As Range
Dim rng2 As Range
Dim srngDif As String

Dim sMsg As String
Dim rng As Range
Dim j As Integer

Set rng1 = Range("A5:B27")
Set rng2 = Range("A13:B20")
srngDif = NotIntersect(rng1, rng2)
If srngDif <> "" Then
Set rngDif = Range(srngDif)

For j = rngDif.Areas.Count To 1 Step -1
sMsg = "range " & j & ": " & rngDif.Areas(j).Address & vbCrLf &
sMsg
Next
MsgBox sMsg

Else
MsgBox "range vuoto"
End If

Set rng1 = Nothing
Set rng2 = Nothing
Set rngDif = Nothing
Set rng = Nothing

[roberto mensa]

ciao scossa ...

io intanto ho terminato il file che allego fa questo:

1)crea una barra (quindi valido per il 2003)

2)fa selezionare il percorso

3)se riconosce una tabella usa quella della cella attiva se no chiede la selezione della tabella

chiede quale colonnna contiene la chiave

4)verifica i nomi della chiave - se uno non è adatto avvisa e si ferma per consentire di cambiare il nome

5)copia i dati nei nuovi file

6)se un file già esiste aggiunge un foglio

 

provare sia la creazione dei file che il richiamo successivo per vedere il risultato.

 

quando ho tempo leggo bene il tuo codice

ciao

r

il file è disponibile anche qui:

https://sites.google.com/site/e90e50/scambio-file col nome crea_file_da_tabella.xls

e qui:

http://groups.google.it/group/excel_vba_free/files?hl=it col nome di SpacchettaInFile_r.xls

 

2010/7/15 Scossa <scos...@gmail.com>

[Scossa]

On 15 Lug, 15:34, roberto mensa <robb....@gmail.com> wrote:

> io intanto ho terminato il file che allego fa questo:

Stasera lo guardo.

>
> quando ho tempo leggo bene il tuo codice

Ho cambiato il tipo restituito dalla funzione Not_Intersect().
Ora restituisce un array() di 2 elementi.

In questo modo può esser usata anche nel foglio:
- selezionare ad esempio H5:I5
- digitare: =not_intersect(B5:B27;B15:B20)
- confermare con ctrl+maiusc+invio
in H5 avremo la prima area
in I5 avremo la seconda area

Questo il codice:


'---------------------------
' Procedure : Not_Intersect
' Author : Scossa
' Date : 15/07/2010
'---------------------------
'
Function Not_Intersect(RngBig As Range, RngSmall As Range) _
As String()

Dim srngBTop As String
Dim srngSTop As String
Dim srngBBtm As String
Dim srngSBtm As String
Dim sRng1Top As String
Dim sRng1Btm As String
Dim sRng2Top As String
Dim sRng2Btm As String
Dim nRowsB As Long
Dim nRowsS As Long
Dim nColsB As Long
Dim nColsS As Long
Dim sRet(0 To 1) As String

nColsB = RngBig.Columns.Count
nColsS = RngSmall.Columns.Count
nRowsB = RngBig.Rows.Count
nRowsS = RngSmall.Rows.Count
srngBTop = RngBig.Cells(1, 1).Address
srngSTop = RngSmall.Cells(1, 1).Address
srngBBtm = RngBig.Cells(nRowsB, nColsB).Address
srngSBtm = RngSmall.Cells(nRowsS, nColsS).Address

If (RngBig.Column = RngSmall.Column) And _
(nRowsB >= nRowsS) And _
(nColsB = nColsS) And _
Not RngBig.Address = RngSmall.Address Then

sRng1Top = RngBig.Cells(1, 1).Address
sRng1Btm = RngSmall.Cells(1, nColsS).Offset(-1).Address
sRng2Top = RngSmall.Cells(nRowsS, 1).Offset(1).Address
sRng2Btm = RngBig.Cells(nRowsB, nColsB).Address

If srngBTop = srngSTop Then

sRet(0) = ""
sRet(1) = sRng2Top & ":" & sRng2Btm

ElseIf srngBBtm = srngSBtm Then

sRet(0) = sRng1Top & ":" & sRng1Btm
sRet(1) = ""
Else
sRet(0) = sRng1Top & ":" & sRng1Btm
sRet(1) = sRng2Top & ":" & sRng2Btm
End If
Else

sRet(0) = ""
sRet(1) = ""

End If

Not_Intersect = sRet

End Function



'----------------

Public Sub test2()

Dim rng1 As Range
Dim rng2 As Range

Dim srngDif() As String

Dim sMsg As String
Dim rng As Range

Set rng1 = Range("A5:B27")
Set rng2 = Range("A13:B20")

srngDif() = Not_Intersect(rng1, rng2)
If srngDif(0) <> "" Then
sMsg = "range sopra: " & srngDif(0) & vbCrLf
'range(srngdif(0)).EntireRow.delete
End If
If srngDif(1) <> "" Then
sMsg = sMsg & "range sotto: " & srngDif(1)
'range(srngdif(1)).EntireRow.delete
End If
If srngDif(0) & srngDif(1) = "" Then
sMsg = "range vuoto"
End If
MsgBox sMsg

Set rng1 = Nothing
Set rng2 = Nothing

Set rng = Nothing

End Sub

Bye!
Scossa

[roberto mensa]

scusa ... ma devono avere stessa larghezza e devono essere uno contenuto nell'altro?

 

ciao

r

 

2010/7/15 Scossa <scos...@gmail.com>

[roberto mensa]

Il giorno 15 luglio 2010 16.20, roberto mensa <robb...@gmail.com> ha scritto:

scusa ... ma devono avere stessa larghezza e devono essere uno contenuto nell'altro?

 

ciao

r

 

tempo fa scrissi questa che mi sembra faccia il lavoro di restituire il range che non è intersecato tra due range ...

Function unionB(rng As Excel.Range, Brng As Excel.Range) As Excel.Range
Dim cella As Excel.Range
Dim irng As Excel.Range
Static bol As Boolean
On Error GoTo nullo
Set irng = Application.Intersect(rng, Brng)

If irng Is Nothing Then
    Set unionB = Union(rng, Brng)
    Exit Function
End If
If rng.Address = Brng.Address Then
    Set unionB = Nothing
    Exit Function
End If

For Each cella In Union(rng, Brng)
    If Application.Intersect(irng, cella) Is Nothing Then
        If bol = False Then
            Set unionB = cella
            bol = True
        Else
            Set unionB = Union(unionB, cella)
        End If
    End If
Next
bol = False
Set irng = Nothing
Exit Function
nullo:
Set unionB = Nothing
Set irng = Nothing
End Function

[roberto mensa]

puoi testare con questa

 

Public Sub test22222()

 Dim rng1 As Range
 Dim rng2 As Range

 Dim rng3 As Range

 Dim srngDif() As String
 Dim sMsg As String
 Dim rng As Range

 Set rng1 = Application.InputBox("primo range", , , , , , , 8)
 If rng1 Is Nothing Then Exit Sub
    rng1 = 1
 
 Set rng2 = Application.InputBox("secondo range", , , , , , , 8)
 If rng2 Is Nothing Then Exit Sub
    rng2 = 2

Set rng3 = unionB(rng1, rng2)

 rng3.Clear
 rng3.Select

End Sub

ha il vantaggio di non andare in errore ogni 2 per 3 (inteso se le misure dei range non sono uguali :-)

ciao

r

 

2010/7/15 roberto mensa <robb...@gmail.com>

[roberto mensa]

risaliva a febbraio 2008 :-) però non mi sembra male ... riincollo dopo aver tolto le cose inutili:

 

Function unionB(rng As Excel.Range, Brng As Excel.Range) As Excel.Range
Dim cella As Excel.Range
Dim irng As Excel.Range
Static bol As Boolean

Set irng = Application.Intersect(rng, Brng)

If irng Is Nothing Then
    Set unionB = Union(rng, Brng)
    Exit Function
End If
If rng.Address = Brng.Address Then
    Set unionB = Nothing
    Exit Function
End If

For Each cella In Union(rng, Brng)
    If Application.Intersect(irng, cella) Is Nothing Then
        If bol = False Then
            Set unionB = cella
            bol = True
        Else
            Set unionB = Union(unionB, cella)
        End If
    End If
Next

End Function

Public Sub test22222()

 Dim rng1 As Range
 Dim rng2 As Range
 Dim rng3 As Range
 Dim srngDif() As String
 Dim sMsg As String
 Dim rng As Range

 Set rng1 = Application.InputBox("primo range", , , , , , , 8)
 If rng1 Is Nothing Then Exit Sub
    rng1 = 1
 
 Set rng2 = Application.InputBox("secondo range", , , , , , , 8)
 If rng2 Is Nothing Then Exit Sub
    rng2 = 2

Set rng3 = unionB(rng1, rng2)

 rng3.Clear
 rng3.Select

End Sub

 

 

viao

r

 

[roberto mensa]

ho anche ritrovato la discussione :-)

ora la rileggo ... c'era ancora Maurizio ... che nostalgia ...

 

http://groups.google.it/group/microsoft.public.it.office.excel/browse_frm/thread/bc753eb7f2f0d325/9dddba05fa02398e?hl=it&lnk=gst&q=unionb#9dddba05fa02398e

 

ciao

r

 

[Scossa]

On 15 Lug, 16:20, roberto mensa <robb....@gmail.com> wrote:
> scusa ... ma devono avere stessa larghezza e devono essere uno contenuto
> nell'altro?

Si, ma volutamente visto lo scopo a cui è destinata.

Bye!
Scossa

[Scossa]

On 15 Lug, 16:51, roberto mensa <robb....@gmail.com> wrote:
> risaliva a febbraio 2008 :-) però non mi sembra male ... riincollo dopo aver
> tolto le cose inutili:
>
> Function unionB(rng As Excel.Range, Brng As Excel.Range) As Excel.Range

Bella, mi piace.

> For Each cella In Union(rng, Brng)
>     If Application.Intersect(irng, cella) Is Nothing Then
>         If bol = False Then
>             Set unionB = cella
>             bol = True
>         Else
>             Set unionB = Union(unionB, cella)
>         End If
>     End If
> Next

hmmm... non è che con grossi range il ciclo rallenta l'esecuzione?
Poi la provo.

Comunque vedo di adattarla e usarla in SpacchettaInFile() e
confrontare i tempi.

Bye!
Scossa

[roberto mensa]

Ma sei fissato coi tempi :-)

Il 15/07/10, Scossa<scos...@gmail.com> ha scritto:

[Scossa]

On 15 Lug, 19:18, roberto mensa <robb....@gmail.com> wrote:
> Ma sei fissato coi tempi :-)
>

Lavoro quotidianamente con file di 20.000 ~ 50.000 righe :-)

Bye!
Scossa

[roberto mensa]

Allora in parte sei giustificato :-)

Il 15/07/10, Scossa<scos...@gmail.com> ha scritto:

[Scossa]

Ciao Rob,

ho studiato :-) e fatto un po' di test sul solito archivio:

creare 25 file dal foglio di 21.760 righe con 25 valori di chiave
univoca, il file è depositato qui:

http://groups.google.it/group/excel_vba_free/web/SpacchettaInFile5.xls?hl=it

E' un po' cicciotto perche contiene i dati per la prova.

Le prove le ho ripetute per 3 volte per ogni function utilizzata ed i
tempi si sono sempre ripetuti uguali:

con la tua function UnionB()
che restituisce un range ma usa un ciclo for:
test in 36 secondi

con la mia function: Not_Intersect()
che restituisce un array di 2 stringhe:
test in 16 secondi

con la mia function: Not_IntersectR() che restituisce un range
ma non usa un ciclo for:
test in 17 secondi

Come temevo, il ciclo "for each cella" su un range esteso rallenta
decisamente l'esecuzione del programma (impiega il doppio delle
altre).

A proposito, hai dichiarato la variabile bol come statica, forse
perchè pensavi ad un uso ricorsivo della function, giusto?
Comunque nel file per il test lo dichiarata local.


Queste la parte di codice di SpacchettaInFile che contiene le uniche
differenze per le 3 chiamate alle function (deccomnetando quella da
testare e commentando le altre):


''**************************************
''UnionB -> excel.range
''**************************************
' ws.Range(aOrigine(j)(2)).EntireRow.Copy
Destination:=.Range(aOrigine(j)(2)).EntireRow
' unionB(.Range(srngDati), .Range(aOrigine(j)
(2))).EntireRow.Delete
''*****************************************


'**************************************
'Not_Intersect -> array() di 2 stringhe
'**************************************
' srngDif() = Not_Intersect(.Range(srngDati), .Range(aOrigine(j)
(2)))
' If srngDif(1) <> "" Then
' .Range(srngDif(1)).EntireRow.Delete
' End If
' If srngDif(0) <> "" Then
' .Range(srngDif(0)).EntireRow.Delete
' End If
' If (srngDif(0) & srngDif(1)) <> "" Then
' ws.Range(aOrigine(j)(2)).EntireRow.Copy
Destination:=.Range(sFirst)
' End If
'*****************************************


''**************************************
'' Not_intersectR -> excel.range
''**************************************
' ws.Range(aOrigine(j)(2)).EntireRow.Copy
Destination:=.Range(aOrigine(j)(2)).EntireRow
' Not_IntersectR(.Range(srngDati), .Range(aOrigine(j)
(2))).EntireRow.Delete
''**************************************


Queste le 3 function:

'***************
Function unionB(rng As Excel.Range, Brng As Excel.Range) _
As Excel.Range
'***************

Dim cella As Excel.Range
Dim irng As Excel.Range

Dim bol As Boolean

Set irng = Application.Intersect(rng, Brng)
If irng Is Nothing Then
Set unionB = Union(rng, Brng)
Exit Function
End If
If rng.Address = Brng.Address Then
Set unionB = Nothing

Set irng = Nothing
Exit Function
End If

For Each cella In Union(rng, Brng)
If Application.Intersect(irng, cella) Is Nothing Then
If bol = False Then
Set unionB = cella
bol = True
Else
Set unionB = Union(unionB, cella)
End If
End If
Next

Set irng = Nothing
End Function

'***************

Function Not_Intersect(RngBig As Range, RngSmall As Range) _
As String()

'***************

'***************
Function Not_IntersectR(RngBig As Range, RngSmall As Range) _
As Excel.Range
'***************

Dim srngBTop As String
Dim srngSTop As String
Dim srngBBtm As String
Dim srngSBtm As String
Dim sRng1Top As String
Dim sRng1Btm As String
Dim sRng2Top As String
Dim sRng2Btm As String
Dim nRowsB As Long
Dim nRowsS As Long
Dim nColsB As Long
Dim nColsS As Long

Dim sRet As String

nColsB = RngBig.Columns.Count
nColsS = RngSmall.Columns.Count
nRowsB = RngBig.Rows.Count
nRowsS = RngSmall.Rows.Count
srngBTop = RngBig.Cells(1, 1).Address
srngSTop = RngSmall.Cells(1, 1).Address
srngBBtm = RngBig.Cells(nRowsB, nColsB).Address
srngSBtm = RngSmall.Cells(nRowsS, nColsS).Address

If (RngBig.Column = RngSmall.Column) And _
(nRowsB >= nRowsS) And _
(nColsB = nColsS) And _
Not RngBig.Address = RngSmall.Address Then

sRng1Top = RngBig.Cells(1, 1).Address
sRng1Btm = RngSmall.Cells(1, nColsS).Offset(-1).Address
sRng2Top = RngSmall.Cells(nRowsS, 1).Offset(1).Address
sRng2Btm = RngBig.Cells(nRowsB, nColsB).Address

If srngBTop = srngSTop Then

sRet = sRng2Top & ":" & sRng2Btm

ElseIf srngBBtm = srngSBtm Then

sRet = sRng1Top & ":" & sRng1Btm
Else
sRet = sRng1Top & ":" & sRng1Btm & "," & sRng2Top & ":" &
sRng2Btm
End If
Set Not_IntersectR = Range(sRet)
Else

Set Not_IntersectR = Nothing

End If

End Function
'--------------------------


Bye!
Scossa

[Scossa]

> ho anche ritrovato la discussione :-)
> ora la rileggo ... c'era ancora Maurizio ... che nostalgia ...
>

WOW!


Bye!
Scossa

[Scossa]

On 15 Lug, 16:51, roberto mensa <robb....@gmail.com> wrote:

Mi spieghi perchè:

> Static bol As Boolean

E' in previsione di un uso ricorsivo della function?


Per lo stesso motivo non sarebbe meglio settare a nothing anche irng,
sia qui:

> If rng.Address = Brng.Address Then
>     Set unionB = Nothing

Set irng = Nothing

>     Exit Function
> End If


che qui:


> Next

Set irng = Nothing

> End Function

Bye!
Scossa

[roberto mensa]

2010/7/15 Scossa <scos...@gmail.com>

On 15 Lug, 16:51, roberto mensa <robb....@gmail.com> wrote:


Mi spieghi perchè:

> Static bol As Boolean

 

e che ne so io :-) l'ho scritta nel 2008 chissiricorda :-D

 

 

E' in previsione di un uso ricorsivo della function?

 

non saprei proprio ... giuro secondo me non serve a nulla che sia static

 

 

Per lo stesso motivo non sarebbe meglio settare a nothing anche irng,
sia qui:

> If rng.Address = Brng.Address Then
>     Set unionB = Nothing

     Set irng = Nothing

>     Exit Function
> End If


che qui:


> Next

 Set irng = Nothing

> End Function

Bye!
Scossa

secondo me no ... a fine routine non serve a nulla ... e adesso non ti ci mettere anche tu con questa storia ... già c'è mauro :-)

scherzi  a parte ... questione di abitudine e di capire quando invece sarebbe necessario ...

ciao

r

 

p.s.

quindi direi che va bene così:

 

Function unionB(rng As Excel.Range, Brng As Excel.Range) As Excel.Range
Dim cella As Excel.Range
Dim irng As Excel.Range

Dim bol As Boolean

Set irng = Application.Intersect(rng, Brng)
If irng Is Nothing Then
    Set unionB = Union(rng, Brng)
    Exit Function
End If

If rng.Address = Brng.Address Then
    Set unionB = Nothing

    Exit Function
End If
For Each cella In Union(rng, Brng)
    If Application.Intersect(irng, cella) Is Nothing Then
        If bol = False Then
            Set unionB = cella
            bol = True
        Else
            Set unionB = Union(unionB, cella)
        End If
    End If
Next
End Function

 

p.s. 2

 

ti rispondo qui anche sul discorso dei tempi ...

secondo me diventano importanti quando se ne ha l'effetiva esigenza ... personalmente cerco e l'ho sempre detto ... di scrivere funzioni che siano prima di tutto ad ampio raggio ... il più possibile ad ampio raggio e riutilizzabili ... unionb ne è un esempio ... ne abbiamo già parlato ... se devo scrivere un codice veloce è perchè c'è una particolare procedura che lo richiede ... ci deve essere un esigenza se no prediligo codice riutilizzabile, bello e semplice (quando mi riesce) oltre che provare a sperimentare nuove strade ... avevamo tempo fa parlato delle regexp ricordi? ... nono postai i miei test ... ma sistemando il codice e aggiungendo i riferimenti le mie regexp riuscivano a battere le tue function con split ... però erano procedure e a differenza delle funzioni che avevo proposto non erano certo riutilizzabili facilmente ... è cosa ben diversa scrivere un codice che *debba* lavorare su milioni di dati ... e invece scrivere una funzione bella ... poi percarità se è bella e anche veloce ... meglio :-)

comunque sistema la tua in modo che uno possa passare 2 range qualsiasi (gestisci i casi)... e usa la tua ... alla fine io faccio sempre così :-)

 

ciao

r