Accelerare Ciclo For

Hai un problema con Excel?

Nuova discussione

Accelerare Ciclo For
di Bodemiller (utente non iscritto) data: 04/07/2016 16:35:24
Ciao a tutti; (come noterete) sono alle prime armi con VBA. Di seguito riporto un codice per un ciclo for: le domande sono 2:
1) Lun ho messo = 3510 ma vorrei scrivere il codice in modo che ricavi la "lun" calcolando il numero di righe non vuote riferite alla colonna a; in altre parole l'iterazione deve essere eseguita per tutte le righe della colonna a non vuote
2) il codice funziona ma è molto lento; in previsione di ampliarlo con altre istruzioni è possible scriverlo in modo da renderlo più immediato?

Grazie mille

Sub Welcome1()

lun = 3510

'inizializza indici di riga e di colonna
r_new = 2

c_new_1 = 1
'colonna a nuovo foglio dove mettere id riga
c_new_2 = 2
'colonna nuovo foglio dove mettere nome operatore
c_new_3 = 3
'colonna c dove mettere la data
c_new_4 = 4
'colonna d dove mettere l'esito
c_new_5 = 5
'colonna d dove mettere sblocco
c_new_6 = 6
'colonna f dove mettere ID Ana
c_new_7 = 7
'colonna g dove mettere Lotto


c_old_1 = 14
' colonna n del foglio Svolti
c_old_2 = 2
' colonna b del foglio Svolti
c_old_3 = 3
' colonna c del foglio Svolti
c_old_4 = 15
' colonna o del foglio Svolti
c_old_5 = 16
' colonna p del foglio Svolti
c_old_6 = 5
' colonna e del foglio Svolti
c_old_7 = 1
' colonna a del foglio Svolti


Foglio_old = "Svolti"
Foglio_new = "DBWlc"
'iterazione su tutte le righe della colonna a (c_old_7)

r_old_start = 2
r_old_end = lun

For r_old = r_old_start To r_old_end
'per tutte le righe del foglio Svolti a partire dalla 2 per tutta la lun

If Sheets(Foglio_old).Cells(r_old, c_old_7).Value <> "" Then
'se nel foglio Welcome la cella di coordinate r_old (2) c_old_6 (a) è diverso da vuoto allora..

Sheets(Foglio_old).Cells(r_old, c_old_1).Copy
Sheets(Foglio_new).Cells(r_new, c_new_1).PasteSpecial xlPasteValues
'..seleziona la celle del foglio Sheet1 della colonna "n" (c_old_1) della riga (r_old) corrispondente
'a quella in cui il valore della colonna a è stato trovato <>"" e copialo e incollalo sulla colonna c_new_1

Sheets(Foglio_old).Cells(r_old, c_old_2).Copy
Sheets(Foglio_new).Cells(r_new, c_new_2).PasteSpecial xlPasteValues
Sheets(Foglio_old).Cells(r_old, c_old_3).Copy
Sheets(Foglio_new).Cells(r_new, c_new_3).PasteSpecial xlPasteValues
Sheets(Foglio_old).Cells(r_old, c_old_4).Copy
Sheets(Foglio_new).Cells(r_new, c_new_4).PasteSpecial xlPasteValues
Sheets(Foglio_old).Cells(r_old, c_old_5).Copy
Sheets(Foglio_new).Cells(r_new, c_new_5).PasteSpecial xlPasteValues
Sheets(Foglio_old).Cells(r_old, c_old_6).Copy
Sheets(Foglio_new).Cells(r_new, c_new_6).PasteSpecial xlPasteValues
Sheets(Foglio_old).Cells(r_old, c_old_7).Copy
Sheets(Foglio_new).Cells(r_new, c_new_7).PasteSpecial xlPasteValues


'Sheets(Foglio_new).Select
'ActiveSheet.Paste
r_new = r_new + 1

End If
Next r_old

End Sub

di patel data: 04/07/2016 16:50:44
allega un file di esempio per poter testare il codice e spiega a cosa serve, magari si può risolvere in altro modo
di Bodemiller (utente non iscritto) data: 04/07/2016 17:13:47
lo scopo della macro è rimettere in ordine i dati del foglio svolti nel foglio DBWlc in questo modo:
nella colonna 1 del foglio DBWlc vanno copiati e riportati i valori della colonna 14 del foglio svolti; di seguito vanno quindi riportati i valori corrispondenti secondi i titoli delle colonne ( di fatto prima copio i valori della colonna 14 sulla colonna 1; poi faccio un cerca vert dei valori della colonna 14 sui valori della colonna 2,3, 15, 16, 5 e 1 del foglio Svolti)
Questa macro di conclude qui; di fatto io vorrei che una volta esauriti i valori della colonna 14, di seguito facesse le stesse operazioni per i valori della colonna 17 (solo celle non vuote: nell'esempio avrei 4 valori), quindi della colonna 20, 23, 26, 29, 32, 35, 38, 41, 44, 46

spero di essermi spiegato .

Grazie

di patel data: 04/07/2016 17:45:48
la prima parte equivalente al tuo codice si può ottenere con questo.
per il resto vorrei vedere il risultato desiderato

Sub a()
With Sheets("Svolti")
  LR = .Cells(Rows.Count, 14).End(xlUp).Row
  .Range(.Cells(2, 14), .Cells(LR, 14)).Copy Sheets("DBWlc").Cells(2, 1)
  .Range(.Cells(2, 2), .Cells(LR, 2)).Copy Sheets("DBWlc").Cells(2, 2)
  .Range(.Cells(2, 3), .Cells(LR, 3)).Copy Sheets("DBWlc").Cells(2, 3)
  .Range(.Cells(2, 15), .Cells(LR, 15)).Copy Sheets("DBWlc").Cells(2, 4)
  .Range(.Cells(2, 16), .Cells(LR, 16)).Copy Sheets("DBWlc").Cells(2, 5)
  .Range(.Cells(2, 5), .Cells(LR, 5)).Copy Sheets("DBWlc").Cells(2, 6)
  .Range(.Cells(2, 1), .Cells(LR, 1)).Copy Sheets("DBWlc").Cells(2, 7)
End With
LR = Cells(Rows.Count, "A").End(xlUp).Row
End Sub

di Bodemiller (utente non iscritto) data: 04/07/2016 17:55:14
Patel grazie mille dell'aiuto

ho mandato il risultato
di patel data: 04/07/2016 18:45:39
perché nel risultato ci sono 20 righe invece che 18 (14+4) ?
di Bodemiller (utente non iscritto) data: 04/07/2016 18:49:20
perchè sono 14 + 4 della colonna 17 + 2 della colonna 44

di patel data: 04/07/2016 19:01:16
prova questa

Sub a()
Application.ScreenUpdating = False
With Sheets("Svolti")
  LR = .Cells(Rows.Count, 14).End(xlUp).Row
  .Range(.Cells(2, 14), .Cells(LR, 14)).Copy Sheets("DBWlc").Cells(2, 1)
  .Range(.Cells(2, 2), .Cells(LR, 2)).Copy Sheets("DBWlc").Cells(2, 2)
  .Range(.Cells(2, 3), .Cells(LR, 3)).Copy Sheets("DBWlc").Cells(2, 3)
  .Range(.Cells(2, 15), .Cells(LR, 15)).Copy Sheets("DBWlc").Cells(2, 4)
  .Range(.Cells(2, 16), .Cells(LR, 16)).Copy Sheets("DBWlc").Cells(2, 5)
  .Range(.Cells(2, 5), .Cells(LR, 5)).Copy Sheets("DBWlc").Cells(2, 6)
  .Range(.Cells(2, 1), .Cells(LR, 1)).Copy Sheets("DBWlc").Cells(2, 7)
  For c = 17 To 46 Step 3
    LR1 = Sheets("DBWlc").Cells(Rows.Count, 2).End(xlUp).Row + 1
    LR = .Cells(Rows.Count, c).End(xlUp).Row
    .Range(.Cells(2, c), .Cells(LR, c)).Copy Sheets("DBWlc").Cells(LR1, 1)
    .Range(.Cells(2, 2), .Cells(LR, 2)).Copy Sheets("DBWlc").Cells(LR1, 2)
    .Range(.Cells(2, 3), .Cells(LR, 3)).Copy Sheets("DBWlc").Cells(LR1, 3)
    .Range(.Cells(2, 15), .Cells(LR, 15)).Copy Sheets("DBWlc").Cells(LR1, 4)
    .Range(.Cells(2, 16), .Cells(LR, 16)).Copy Sheets("DBWlc").Cells(LR1, 5)
    .Range(.Cells(2, 5), .Cells(LR, 5)).Copy Sheets("DBWlc").Cells(LR1, 6)
    .Range(.Cells(2, 1), .Cells(LR, 1)).Copy Sheets("DBWlc").Cells(LR1, 7)
  Next
End With
LR1 = Sheets("DBWlc").Cells(Rows.Count, 2).End(xlUp).Row
With Sheets("DBWlc")
  For r = LR1 To 2 Step -1
    If Cells(r, 1) = "" Then Rows(r).Delete
  Next
End With
Application.ScreenUpdating = True
End Sub

di Bodemiller (utente non iscritto) data: 04/07/2016 19:40:31
ti ho inviato l'errore che mi da

grazie
di Bodemiller (utente non iscritto) data: 04/07/2016 19:43:07
nel debug si seleziona la lettera "c" dopo il comando For e compare il messaggio che ti ho allegato prima
di Vecchio Frac data: 04/07/2016 19:46:19
Per curiosità, come la richiami la sub a() ?
E poi per cortesia, abituatevi a utilizzare *sempre* Option Explicit in testa ai moduli.
di patel data: 05/07/2016 09:30:17
a me funziona, allego file excelvbapatel
di Bodemiller (utente non iscritto) data: 05/07/2016 09:39:29
Confermo che il tuo file funziona

riportandolo sul mio però non funziona: nel debug si evidenzia in giallo la scritta Sub a() e compare il msgbox :
Errore di Compilazione: Prevista Function o variabile
di Gianfranco data: 05/07/2016 10:34:42
scusate l'intrusione
ma il file allegato da
Bodemiller
non ha nessuna macro
magari lo salvi senza attivazione
di patel data: 05/07/2016 11:36:47
prova a cambiare il nome alla sub, magari è in confiltto con altre tue sub, oppure copia tutti i tuoi dati sul mio

Vuoi Approfondire?