[Risolto] Modifica macro

Discussioni sull'applicazione per i fogli di calcolo
Rispondi
coguaro80
Messaggi: 22
Iscritto il: sabato 22 agosto 2020, 9:20

[Risolto] Modifica macro

Messaggio da coguaro80 »

buongiorno a tutti
ho questa macro a cui dovrei fare un paio di modifiche:

Codice: Seleziona tutto

Sub Email
Dim collezione As New Collection
   Sh = ThisComponent.Sheets.getByName("Foglio1") 
   c = Sh.createCursor
   c.gotoEndOfUsedArea(false)
   LastRow = c.RangeAddress.EndRow
   Lista() = Sh.getCellRangeByName("Q2:Q" & LastRow + 1).GetDataArray
   
   For i = 0 To Ubound(Lista)
      codice = Split(Lista(i)(0), ", ")
           
         On Error Resume Next
         For n = 0 To Ubound(codice)
             Verifica:
             cod1 = Instr(codice(n),"@") : cod2 = Instr(codice(n),".")
             If cod1 > 0 And cod2 > 0 Then 
                collezione.Add(codice(n), CStr(Codice(n)))
             Else
                codice(n) = InputBox  ("Verificare esattezza indirizzo email: ","Verifica",codice(n) )
                Goto Verifica
             End if   
         Next n
  
   Next i 
   On Error Goto 0


oDoc = StarDesktop.loadComponentFromURL( "private:factory/scalc", "_blank", 0, Array() )
   Sh2 = oDoc.Sheets.getByName("Foglio1") 
   Sh2.getCellByPosition(0, x).String = "e-mail"
   For x = 1 To collezione.Count
      Sh2.getCellByPosition(0, x).String = collezione(x)
      Dati = Split(collezione(x), "@")
      Dati2 = Split(collezione(x), ".")
      Sh2.getCellByPosition(1, x).String = Dati(0)
      Sh2.getCellByPosition(2, x).String = Dati(1)
      Sh2.getCellByPosition(3, x).String = Dati2(Ubound(Dati2))
   Next x

c = Sh2.createCursor
c.gotoEndOfUsedArea(false)
LastRow = c.RangeAddress.EndRow

Dim OrdineCampi(2) As New com.sun.star.table.TableSortField
Dim mDescriptorOrden()
Range = Sh2.getCellRangeByPosition(0, 1, 3, LastRow)
mDescriptorOrden = Range.createSortDescriptor()
   
   OrdineCampi(0).Field = 2
   OrdineCampi(0).IsAscending = True
   OrdineCampi(0).IsCaseSensitive = False
   OrdineCampi(0).FieldType = com.sun.star.table.TableSortFieldType.AUTOMATIC
   OrdineCampi(1).Field = 3
   OrdineCampi(1).IsAscending = True
   OrdineCampi(1).IsCaseSensitive = False
   OrdineCampi(1).FieldType = com.sun.star.table.TableSortFieldType.AUTOMATIC
   OrdineCampi(2).Field = 1
   OrdineCampi(2).IsAscending = True
   OrdineCampi(2).IsCaseSensitive = False
   OrdineCampi(2).FieldType = com.sun.star.table.TableSortFieldType.AUTOMATIC
   
   mDescriptorOrden(1).Name = "ContainsHeader"
   mDescriptorOrden(1).Value = False
   mDescriptorOrden(3).Name = "SortFields"
   mDescriptorOrden(3).Value = OrdineCampi

   Range.sort( mDescriptorOrden )  
Sh2.getCellRangeByPosition(1, 1, 3, LastRow).ClearContents(1023)
Dim prop()
adressDoc = convertToURL("p:\email.xls")   '<<<<<< da modificare
oDoc.storeAsURL(adressDoc, prop() )
oDoc.close(true)    
End Sub
1) il file creato a estensione xls ma non è un file xls perchè non viene riconosciuto dalla piattaforma su cui lo carico sto ovviando riaprendo il file e forzandolo come file excel xls ma vorrei riuscire a non fare questo ulteriore passaggio
2) spostare nel secondo file le mail dalla colonna A alla colonna B
3) dal file iniziale oltre a copiare gli indirizzi mail avrei bisogno che mi prendesse altre informazioni che sono nelle colonne A & D e le mettesse in una unica colonna la A che però rimangano sempre collegate al campo mail che è la colonna Q anche nel caso di più mail nella stessa riga in questo caso dovrebbe ricreare due righe con le due mail ma le stesse informazioni prese da A & D una riga collegata alla prima mail e una riga collegata alla seconda mail
3) modificare l'ordinamento che adesso viene fatto in base alla casella mail ma con queste modifiche vorrei venga fatto in base alla colonna A del secondo file che appunto andrebbe a contenere i dati delle colonne A & D del primo file

spero di essermi spiegato bene
Allegati
email.xls
esempio del file come dovrebbe venire
(7 KiB) Scaricato 125 volte
Soggetti.ods
file esportato dal gestionale
(12.42 KiB) Scaricato 109 volte
Ultima modifica di coguaro80 il martedì 1 settembre 2020, 23:12, modificato 1 volta in totale.
Apache OpenOffice 4.1.7 su Windows 10 Professional
geovign
Messaggi: 219
Iscritto il: domenica 13 gennaio 2019, 11:19
Località: Modena

Re: Modifica macro

Messaggio da geovign »

Ciao coguaro80,
spero di aver centrato la tua richiesta... per fortuna che hai allegato il risultato voluto...
Da modificare il percorso del file email.xls con "p:\email.xls" se è ancora valido.
Saluti
Geo
Allegati
Soggetti_1.ods
(15.33 KiB) Scaricato 111 volte
LibO v.24 su Manjaro
coguaro80
Messaggi: 22
Iscritto il: sabato 22 agosto 2020, 9:20

Re: Modifica macro

Messaggio da coguaro80 »

ti ringrazio la macro funziona bene l'unica cosa che non riesco a capire è il motivo per il quale per fare un file di 14000 righe e circa 16000 indirizzi mail considerando quelli che ne hanno 2 per riga ci voglia una marea di tempo oltre un'ora?
ho visto che mi hai modificato il testo della denominazione portandolo tutto maiuscolo c'è un motivo particolare?
Apache OpenOffice 4.1.7 su Windows 10 Professional
patel
Volontario attivo
Volontario attivo
Messaggi: 4030
Iscritto il: venerdì 30 aprile 2010, 8:04
Località: Livorno

Re: Modifica macro

Messaggio da patel »

per ridurre i tempi occorre disabilitare l'aggiornamento video all'inizio del ciclo e riabilitarlo dopo, credo si faccia così:

Codice: Seleziona tutto

ThisComponent.addActionLock
ThisComponent.LockControllers = Application.ScreenUpdating = false
..... cicli ....
ThisComponent.UnlockControllers = Application.ScreenUpdating = True 
-------------------
Libre Office 7.5.3.2 su Windows 11
allega un file di esempio, guadagnerai tempo tu e lo farai risparmiare a chi ti aiuta
geovign
Messaggi: 219
Iscritto il: domenica 13 gennaio 2019, 11:19
Località: Modena

Re: Modifica macro

Messaggio da geovign »

coguaro80 ha scritto:... ho visto che mi hai modificato il testo della denominazione portandolo tutto maiuscolo c'è un motivo particolare?
Nel tuo file email.xls il testo nella colonna denominazione è maiuscolo, quindi così l'ho impostato.
Se invece vuoi mantenerlo uguale a quanto presente del file Soggetti.ods, sostiuisci
Sh2.getCellRangeByName("A" & RigaInizioScritturaSh2).string = UCase(TestoComposto)
con
Sh2.getCellRangeByName("A" & RigaInizioScritturaSh2).string = TestoComposto
Devi eseguire la sostituzione in due punti del codice.
Forse per 14000 righe un ciclo for/next non è propriamente indicato, magari un altro tipo di istruzione è più performante...
Il problema da te riscontrato in merito alla apertura del file .xls, è ancora presente?
Ad ogni modo, grazie per il riscontro.
Saluti
Geo
LibO v.24 su Manjaro
coguaro80
Messaggi: 22
Iscritto il: sabato 22 agosto 2020, 9:20

Re: Modifica macro

Messaggio da coguaro80 »

patel ha scritto:per ridurre i tempi occorre disabilitare l'aggiornamento video all'inizio del ciclo e riabilitarlo dopo, credo si faccia così:

Codice: Seleziona tutto

ThisComponent.addActionLock
ThisComponent.LockControllers = Application.ScreenUpdating = false
..... cicli ....
ThisComponent.UnlockControllers = Application.ScreenUpdating = True 
se aggiungo il codice sopra all'inizio di tutto

Codice: Seleziona tutto

Sub Email2
ThisComponent.addActionLock
ThisComponent.LockControllers = Application.ScreenUpdating = false
mi dice

Codice: Seleziona tutto

errore di runtime BASIC 
variabile dell'oggetto non impostata
Apache OpenOffice 4.1.7 su Windows 10 Professional
coguaro80
Messaggi: 22
Iscritto il: sabato 22 agosto 2020, 9:20

Re: Modifica macro

Messaggio da coguaro80 »

geovign ha scritto:
coguaro80 ha scritto:... ho visto che mi hai modificato il testo della denominazione portandolo tutto maiuscolo c'è un motivo particolare?
Nel tuo file email.xls il testo nella colonna denominazione è maiuscolo, quindi così l'ho impostato.
Se invece vuoi mantenerlo uguale a quanto presente del file Soggetti.ods, sostiuisci
Sh2.getCellRangeByName("A" & RigaInizioScritturaSh2).string = UCase(TestoComposto)
con
Sh2.getCellRangeByName("A" & RigaInizioScritturaSh2).string = TestoComposto
Devi eseguire la sostituzione in due punti del codice.
Forse per 14000 righe un ciclo for/next non è propriamente indicato, magari un altro tipo di istruzione è più performante...
Il problema da te riscontrato in merito alla apertura del file .xls, è ancora presente?
Ad ogni modo, grazie per il riscontro.
Saluti
Geo
si scusa erano in maiuscolo perchè rispecchiava come era nel file originale alcune sono tutto maiuscole per distinzione
ieri dopo 3 ore che stava andando l'ho dovuto boloccare oggi ci riprovo e vedo quanto ci mette l'ho fatto partire alle 9.44 quando finisce avviso :D
Apache OpenOffice 4.1.7 su Windows 10 Professional
geovign
Messaggi: 219
Iscritto il: domenica 13 gennaio 2019, 11:19
Località: Modena

Re: Modifica macro

Messaggio da geovign »

In origine, quanto tempo ti serviva per compilare il file email.xls con 16000 indirizzi?

EDIT: Presentati nella apposita sezione "Discussioni Generali e Presentazioni", non lo hai ancora fatto....
LibO v.24 su Manjaro
coguaro80
Messaggi: 22
Iscritto il: sabato 22 agosto 2020, 9:20

Re: Modifica macro

Messaggio da coguaro80 »

geovign ha scritto:In origine, quanto tempo ti serviva per compilare il file email.xls con 16000 indirizzi?

EDIT: Presentati nella apposita sezione "Discussioni Generali e Presentazioni", non lo hai ancora fatto....
la macro originale ci mette meno di 5 minuti

hai ragione non ci avevo pensato visto che ero già iscritto ma non riuscivo più a collegarmi con le mie vecchie credenziali e ho fatto un nuovo utente
Apache OpenOffice 4.1.7 su Windows 10 Professional
coguaro80
Messaggi: 22
Iscritto il: sabato 22 agosto 2020, 9:20

Re: Modifica macro

Messaggio da coguaro80 »

l'ho bloccato dopo 5 ore provato su diversi pc sia con open che libre office ma non finisce mai????

http://speccy.piriform.com/results/1fTq ... opbiE56eBu ha questo indirizzo le specifiche del mio pc non è recentissimo ma neanche da buttare?!?!?!?!?

la macro originale in meno di 5 minuti finiva questa dopo 5 ore non è finita e l'ho bloccata
Apache OpenOffice 4.1.7 su Windows 10 Professional
geovign
Messaggi: 219
Iscritto il: domenica 13 gennaio 2019, 11:19
Località: Modena

Re: Modifica macro

Messaggio da geovign »

Mi dispiace per la perdita di tempo.
Prova il codice contenuto nel file allegato.
Modifica il percorso di salvataggio del file email.xls .
Poi facci sapere anche se riesci ad aprire normalmente il file .xls
Saluti
Geo

EDIT: Ho provato ora il codice con 16380 soggetti ed il file generato conta 26600 righe. Tempo: meno di un minuto. Processore: pentium 4
Allegati
Soggetti_2.ods
(19.37 KiB) Scaricato 133 volte
LibO v.24 su Manjaro
patel
Volontario attivo
Volontario attivo
Messaggi: 4030
Iscritto il: venerdì 30 aprile 2010, 8:04
Località: Livorno

Re: Modifica macro

Messaggio da patel »

ciao geovign, giusto allegare il file di esempio, ma fare solo questo costringe tutti a scaricare il file per vedere la soluzione, sarebbe meglio riassumerla a parole e postare il codice.
-------------------
Libre Office 7.5.3.2 su Windows 11
allega un file di esempio, guadagnerai tempo tu e lo farai risparmiare a chi ti aiuta
patel
Volontario attivo
Volontario attivo
Messaggi: 4030
Iscritto il: venerdì 30 aprile 2010, 8:04
Località: Livorno

Re: Modifica macro

Messaggio da patel »

coguaro80 ha scritto: se aggiungo il codice sopra all'inizio di tutto

Codice: Seleziona tutto

Sub Email2
ThisComponent.addActionLock
ThisComponent.LockControllers = Application.ScreenUpdating = false
mi dice

Codice: Seleziona tutto

errore di runtime BASIC 
variabile dell'oggetto non impostata
Scusami, ho sbagliato a incollare, le istruzioni sono:

Codice: Seleziona tutto

myDoc = ThisComponent
myDoc.lockControllers()
myDoc.addActionLock()
' --- modify your cells here ---
myDoc.removeActionLock()
myDoc.unlockControllers()
però la soluzione postata da geovign che usa il SEARCH invece dei cicli for è sicuramente migliore
-------------------
Libre Office 7.5.3.2 su Windows 11
allega un file di esempio, guadagnerai tempo tu e lo farai risparmiare a chi ti aiuta
coguaro80
Messaggi: 22
Iscritto il: sabato 22 agosto 2020, 9:20

Re: Modifica macro

Messaggio da coguaro80 »

geovign ha scritto:Mi dispiace per la perdita di tempo.
Prova il codice contenuto nel file allegato.
Modifica il percorso di salvataggio del file email.xls .
Poi facci sapere anche se riesci ad aprire normalmente il file .xls
Saluti
Geo

EDIT: Ho provato ora il codice con 16380 soggetti ed il file generato conta 26600 righe. Tempo: meno di un minuto. Processore: pentium 4
:bravo: :bravo: :bravo: :bravo: :bravo: :bravo: :bravo: :bravo: :bravo:
il file xls viene generato correttamente e la piattaforma lo riconosce senza problemi
la velocità è buona
però non trascrive correttamente le mail che hanno - o _ nella mail in questo caso non mi restituisce l'indirizzo completo ma solo una parte
in allegato una prova
Allegati
Soggetti_3.ods
file di partenza
(19.52 KiB) Scaricato 102 volte
NomeFile.xls
risultato
(6.5 KiB) Scaricato 87 volte
Apache OpenOffice 4.1.7 su Windows 10 Professional
geovign
Messaggi: 219
Iscritto il: domenica 13 gennaio 2019, 11:19
Località: Modena

Re: Modifica macro

Messaggio da geovign »

Risolto il problema della trascrizione degli indirizzi mail contenenti il carattere "-". Era dovuto dall'uso del carattere "-" quale separatore nel concatenamento di testi per la definizione della variabile "TestoPerScrittura"; ora viene utilizzato il carattere "|" e speriamo che nessun indirizzo mail lo contenga....
Non ho riscontrato anomalie per il carattere "_" contenuto negli indirizzi.
Di seguito il codice modificato

Codice: Seleziona tutto

Sub Email5
	Dim FileSoggetti as object
	dim Sh as object
	FileSoggetti = ThisComponent
	Sh = FileSoggetti.Sheets.getByName("Foglio1")
rem determinazione ultima riga del foglio in FileSoggetti
	dim c as object
	dim UltimaRigaFileSoggetti as long
	dim UltimaColonnaFileSoggetti as long
	c = Sh.createCursor
	c.gotoEndOfUsedArea(false)
	UltimaRigaFileSoggetti = c.RangeAddress.EndRow
	UltimaColonnaFileSoggetti = c.RangeAddress.EndColumn
rem cerco l'indice delle colonne "cod.", "denominazione","email"
	dim RangeIntestazioneColonne as object
	dim oDescriptor
	dim oFound
	dim ColonnaCod as long
	dim ColonnaDenominazione as long
	dim ColonnaEmail as long
	RangeIntestazioneColonne = Sh.getCellRangeByPosition(0,0,UltimaColonnaFileSoggetti,0)
	oDescriptor = RangeIntestazioneColonne.createSearchDescriptor()
	'cod.
	With oDescriptor						'proprietà di ricerca
		.SearchString = "cod."				'testo da cercare
		.SearchWords = True					'vero che sono parole
		.SearchType = 1						'inteso come contenuto cella
		.SearchCaseSensitive = False		'ignora maiuscolo/minuscolo
	End With
	oFound = RangeIntestazioneColonne.findFirst(oDescriptor)
	ColonnaCod = oFound.getCellAddress.Column	'numero indice della colonna 
	'denominazione
	With oDescriptor
		.SearchString = "denominazione"
		.SearchWords = True
		.SearchType = 1
		.SearchCaseSensitive = False
	End With
	oFound = RangeIntestazioneColonne.findFirst(oDescriptor)
	ColonnaDenominazione = oFound.getCellAddress.Column
	'e-mail
	With oDescriptor
		.SearchString = "e-mail"
		.SearchWords = True
		.SearchType = 1
		.SearchCaseSensitive = False
	End With
	oFound = RangeIntestazioneColonne.findFirst(oDescriptor)
	ColonnaEmail = oFound.getCellAddress.Column
rem inizio istruzioni per raccolta in "collezione" delle stringe da scrivere nel FileEmail
	dim RangeDati as object
	dim ArrDati as object
	dim NumeroRighe as long
	dim IndiceRiga as long
	dim NumeroCicli as long
	dim Dato as string
	dim ArrEmail()
	dim n as integer
	dim cod1 as integer
	dim cod2 as integer
	dim Testo1 as string
	dim Testo2 as string
	dim TestoComposto as string
	dim ArrTesto() as variant
	dim TestoPerScrittura as string
	Dim Collezione As New Collection
	RangeDati = Sh.getCellRangeByPosition(0,1,UltimaColonnaFileSoggetti,UltimaRigaFileSoggetti)	'insieme delle celle contenti i dati escluso intestazione colonne
	ArrDati() = RangeDati.getDataArray()	'insieme bi-dimensionale dei dati contenuti nelle celle
	NumeroRighe = RangeDati.Rows.Count		'numero di righe di RangeDati
	IndiceRiga = 0		'indice della prima riga dell'insieme bi-dimensionale di dati
	NumeroCicli = NumeroRighe -1	'numero di cicli da effettuare
	Do While IndiceRiga <= NumeroCicli	'ciclo condizionato: se condizione "vera" esegue il ciclo
		Dato = ArrDati(IndiceRiga)(ColonnaEmail)	'valore (stringa)
		On Error Resume next	'gestione errore nel caso Dato sia vuoto
		ArrEmail() = Split(Dato, ", ")	'suddivide il valore in una matrice in base al separatore ", "
		For n = 0 To Ubound(ArrEmail())	'ciclo all'interno all'interno della matrice arrEmail
			Verifica:
			cod1 = Instr(arrEmail(n),"@") : cod2 = Instr(arrEmail(n),".")
			If cod1 > 0 And cod2 > 0 Then	'se cod1 e cod2 sono maggiori di 0 allora lindirizzo mail contiene @ ed almeno un punto
				Testo1 = ArrDati(IndiceRiga)(ColonnaCod)	'testo cella colonna A
				Testo2 = ArrDati(IndiceRiga)(ColonnaDenominazione)	'testo cella colonna D
				TestoComposto = Testo1 & " " & Testo2 	'somma dei due testi
				ArrTesto() = Array(TestoComposto,arrEmail(n))	'insieme dei testi
				TestoPerScrittura = Join(ArrTesto(),"|")	'concatena l'insieme dei due testi separati da "|"
				Collezione.Add(TestoPerScrittura, CStr(TestoPerScrittura))	'inserisce il testo nella collezione
			Else
				arrEmail(n) = InputBox ("Verificare esattezza indirizzo email: ","Verifica",arrEmail(n) )
				Goto Verifica
			end if
		next n
			On Error GoTo 0
		IndiceRiga = IndiceRiga +1	'aumento di una unità per passare all'indice successivo
	Loop
rem creazione ed apertura del FileEmail
	dim FileEmail as object
	dim Sh2 as object
	dim RigaInizioScritturaSh2 as long
	dim pippo as string
	dim x as long
	dim Stringa
	dim i as integer
	FileEmail = StarDesktop.loadComponentFromURL( "private:factory/scalc", "_default", 0, Array() )
	Sh2 = FileEmail.Sheets.getByName("Foglio1")
	Sh2.getCellRangeByName("A1").string = "denominazione"	'testo cella A1
	Sh2.getCellRangeByName("A1").CharWeight= 150	'grassetto
	Sh2.getCellRangeByName("B1").string = "e-mail"	'testo cella B1
	Sh2.getCellRangeByName("B1").CharWeight= 150	'grassetto
rem inizio scrittura dei dati contenuti in "collezione"
	RigaInizioScritturaSh2 = 2	'riga di partenza per scrittura su FoglioEmail
	For x = 1 To Collezione.Count	'tanti cicli quanti sono gli elementi che costituiscono la collezione
		Stringa = split(Collezione(x),"|")
		For i = 0 to UBound(Stringa)	'sono sempre previsti due cicli
			if i = 0 then
				Sh2.getCellRangeByName("A" & RigaInizioScritturaSh2).string = Stringa(i)	'scrive denominazione
			else
				Sh2.getcellRangeByName("B" & RigaInizioScritturaSh2).string = Stringa(i)	'scrive e-mail
			end if
		next i
		RigaInizioScritturaSh2 = RigaInizioScritturaSh2 +1	'aumento di una unità per passare alla riga successiva
	Next x
	Sh2.Columns().OptimalWidth = True	'larghezza ottimale di tutte le colonne
rem ordinamento documento email
	dim UltimaRigaFileEmail as long
	dim Range as object
	Dim OrdineCampi(0) As New com.sun.star.util.SortField
	Dim mDescriptorOrden(0) As New com.sun.star.beans.PropertyValue
	c = Sh2.createCursor
	c.gotoEndOfUsedArea(false)
	UltimaRigaFileEmail = c.RangeAddress.EndRow
	Range = Sh2.getCellRangeByPosition(0, 1, 3, UltimaRigaFileEmail)
	OrdineCampi(0).Field = 0	'riferimento alla colonna A
	OrdineCampi(0).SortAscending = True	'ordinamento ascendete
	mDescriptorOrden(0).Name = "SortFields"
	mDescriptorOrden(0).Value = OrdineCampi()
	Range.sort(mDescriptorOrden()) 
rem salvataggio del FileEmail con estensione xls 
	dim mFileType(0) as new com.sun.star.beans.PropertyValue
	dim adressDoc as string
	mFileType(0).Name = "FilterName"
	mFileType(0).Value="MS Excel 97"
	adressDoc = ConvertToURL("d:\tem\NomeFile.xls")   '<<<<<< da modificare
	FileEmail.StoreAsURL( adressDoc, mFileType())
	FileEmail.close(true)
End Sub
Ora dovrebbe funzionare a dovere.
Saluti
Geo
Allegati
Soggetti_3.ods
(19.13 KiB) Scaricato 104 volte
LibO v.24 su Manjaro
coguaro80
Messaggi: 22
Iscritto il: sabato 22 agosto 2020, 9:20

Re: Modifica macro

Messaggio da coguaro80 »

si confermo con le mail attuali funziona senza problemi
scusa errore mio quello del "_" nel file originale avevo mail che avevano sia il "_" che il "-" e davano problemi pensavo che derivasse anche dal "_"
grazie
Apache OpenOffice 4.1.7 su Windows 10 Professional
geovign
Messaggi: 219
Iscritto il: domenica 13 gennaio 2019, 11:19
Località: Modena

Re: Modifica macro

Messaggio da geovign »

Ciao coguaro80,
perfetto.
Quindi se è tutto a posto ricordati di mettere risolto al primo post (viewtopic.php?f=9&t=5661).
Saluti
Geo
LibO v.24 su Manjaro
Rispondi