Condividi:        

incolonnare dati con condizione

Vuoi potenziare i tuoi documenti Word? Non sai come si fa una macro in Excel? Devi creare una presentazione in PowerPoint?
Oppure sei passato a OpenOffice e non sei sicuro di come lavorare al meglio?

Moderatori: Anthony47, Flash30005

incolonnare dati con condizione

Postdi luca62 » 30/08/16 14:10

Salve, tempo fa il mitico Flash mi costruì con tanta pazienza una macro che dato un foglio di lavoro con tante colonne, mi mettesse in colonna ,dalla seconda riga in poi, in un altro foglio le prime 19 colonne, poi a seguire le successive 19 colonne (ossia da 19 a 38 ) e così via. Pian piano e sè gonfiato e necessita di molto tempopo per essere compilato, anche perchè andavo a copiare le prime 1000 righe delleprime19 colon, poi le incolonnavo con altre 1000 righe e poiuna volta incolonnato andavo a cancellare tutte le righe vuote.
Esiste un modo per far si di copiare il contenuto delle prime 19 colonne (19 è lo step) ma solo per le righe per cui i valori ,nella colonna
C (ad esempio ) sia diverso da zero?
esempio con step solo 4 colonne:
esempio con 2 righe dalla colonna 1 alla 4 con Ci diverso da zero, 3 righe dalla colonna 5 alla 8 con ci diverso da zero:

adesso mi incolonna così:
a2 b2 c2 d2
a3 b3 c3 d3
0 0 0 0

0 0 0 0
e2 f2 g2 h2
e3 f3 g3 h3
e4 f4 g4 h4
0 0 0 0

0 0 0 0
vado quindi ad eliminare tutte le righe dove il valore della 3^ colonne =0
e diventa:
a2 b2 c2 d2
a3 b3 c3 d3
e2 f2 g2 h2
e3 f3 g3 h3
e4 f4 g4 h4

si può fare senza eliminare le celle dove il valore della 3^ colonna =0?
per velocizzare il calcolo?

Codice: Seleziona tutto
 Sub Compila()
    Application.ScreenUpdating = False  '<<<< evita l'aggiornamento schermate (sfarfallio)
    Application.Calculation = xlManual '<<<< ferma il calcolo e velocizza la macro
   
    Set Ws1 = Worksheets("RIEPILOGO ORDINI")
    Set Ws2 = Worksheets("ORDINI TOT")
    Set Ws3 = Worksheets("PARTICOLARI")
    Set Ws4 = Worksheets("COMMERCIALI")
   
    UC1 = Ws1.Cells(2, Columns.Count).End(xlToLeft).Column
    Sheets("ORDINI TOT").Range("A2").Resize(30000, 20).ClearContents
    Sheets("PARTICOLARI").Range("A2").Resize(30000, 20).ClearContents
    Sheets("COMMERCIALI").Range("A2").Resize(30000, 20).ClearContents
   
   
   
    For CCR = 1 To UC1 - 5 Step 19
    UR1 = Ws1.Range("A" & Rows.Count).End(xlUp).Row
    Ws1.Range(Ws1.Cells(2, CCR), Ws1.Cells(UR1, CCR + 18)).Copy
    Ws2.Select
    UR2 = Ws2.Range("A" & Rows.Count).End(xlUp).Row + 1
    Range("A" & UR2).Select
        ActiveSheet.Paste
       
    Range("J:J,L:L,P:P,R:R").Select
    Range("L1").Activate
    Selection.NumberFormat = "d/m/yy;@"
   
 
    Next CCR
    UR2 = Ws2.Range("A" & Rows.Count).End(xlUp).Row
    For RR2 = UR2 To 1 Step -1
    If Ws2.Range("C" & RR2).Value = 0 Then Rows(RR2).Delete
   
 
    Next RR2
    UR2 = Ws2.Range("A" & Rows.Count).End(xlUp).Row
    For RR2 = 2 To UR2
    If Val(Ws2.Range("E" & RR2)) >= 1 And Val(Ws2.Range("E" & RR2)) <= 299999 And Val(Ws2.Range("E" & RR2)) <> 999 Then
    Ws2.Range("A" & RR2 & ":s" & RR2).Copy Destination:=Ws3.Cells(Rows.Count, 1).End(xlUp).Offset(1, 0)
    Else
   
    Ws2.Range("A" & RR2 & ":s" & RR2).Copy Destination:=Ws4.Cells(Rows.Count, 1).End(xlUp).Offset(1, 0)
   
    End If
    Next RR2
 
    Ws2.Range("A1:s1").Copy Destination:=Ws3.Range("A1")
    Ws2.Range("A1:s1").Copy Destination:=Ws4.Range("A1")
   
   
   
    Application.Calculation = xlCalculationAutomatic  '<<<< ripristina il calcolo
    Application.ScreenUpdating = True   '<<<< ripristina l'aggiornamento schermate
    End Sub


grazie!
luca62 office2007 window7
luca62
Utente Senior
 
Post: 173
Iscritto il: 23/12/12 14:54

Sponsor
 

Re: incolonnare dati con condizione

Postdi Anthony47 » 31/08/16 00:26

Pubblica un file di prova e vedremo cosa si puo' fare.

Per le istruzioni su come allegare un file:
viewtopic.php?f=26&t=103893&p=605487#p605487

Cia
Avatar utente
Anthony47
Moderatore
 
Post: 19196
Iscritto il: 21/03/06 16:03
Località: Ivrea

Re: incolonnare dati con condizione

Postdi luca62 » 01/09/16 18:35

http://www.filedropper.com/com5016
ecco il file, la macro in questione è la Compila

grazie!
luca62 office2007 window7
luca62
Utente Senior
 
Post: 173
Iscritto il: 23/12/12 14:54

Re: incolonnare dati con condizione

Postdi Anthony47 » 05/09/16 02:18

Complice impegni ancora assillanti il tuo file mi era sfuggito, chiedo scusa...
Questa variante della macro potrebbe dare i risultati sperati:
Codice: Seleziona tutto
Sub CompilAz()
Dim WArr, myRan As Range, OArr(), pArr(), cArr, LBWA As Long, I As Long, J As Long
Dim jInd As Long, pInd As Long, cInd As Long

'Application.ScreenUpdating = False  '<<<< evita l'aggiornamento schermate (sfarfallio)
'Application.Calculation = xlManual '<<<< ferma il calcolo e velocizza la macro

Set ws1 = Worksheets("RIEPILOGO ORDINI")
Set WS2 = Worksheets("INCOLONNA")
Set ws3 = Worksheets("PARTICOLARI")
Set ws4 = Worksheets("COMMERCIALI")
uc1 = ws1.Cells(1, Columns.Count).End(xlToLeft).Column
WS2.Range("A2:Z" & Rows.Count).ClearContents
ws3.Range("A2:Z" & Rows.Count).Cells.ClearContents
ws4.Range("A2:Z" & Rows.Count).Cells.ClearContents
ur1 = ws1.Cells(Rows.Count, 1).End(xlUp).Row
ReDim OArr(LBWA To ur1 * Int(uc1 / 19), 1 To 19)
ReDim pArr(LBWA To ur1 * Int(uc1 / 19), 1 To 5)
ReDim cArr(LBWA To ur1 * Int(uc1 / 19), 1 To 5)
mytim = Timer

For ccr = 1 To uc1 - 4 Step 19
'    Set myRan = Cells(1, 1).Offset(0, (ccr - 1) * 19).Resize(1000, 19)
    ur1 = ws1.Cells(Rows.Count, 1).Offset(0, ccr - 1).End(xlUp).Row
    WArr = ws1.Cells(2, 1).Offset(0, (ccr - 1)).Resize(ur1, 19).Value
    LBWA = LBound(WArr, 1)
    For I = LBWA To UBound(WArr, 1)
        If WArr(I, LBWA + 2) <> 0 Then
            For J = LBWA To UBound(WArr, 2)
                OArr(LBWA + jInd, J) = WArr(I, J)
                If J < 6 Then
                    If WArr(I, LBWA + 3) > 0 And WArr(I, LBWA + 3) < 2000000 Then
                            pArr(LBWA + pInd, J) = WArr(I, J)
                            myp = True: myc = False
                    Else
                        cArr(LBWA + cInd, J) = WArr(I, J)
                        myc = True: myp = False
                    End If
                End If
            Next J
            jInd = jInd + 1
            If myp Then pInd = pInd + 1 Else cInd = cInd + 1
        End If
    Next I
Next ccr
WS2.Cells(2, 1).Resize(jInd + 1, 19).Value = OArr
ws3.Cells(2, 1).Resize(pInd + 1, 5).Value = pArr
ws4.Cells(2, 1).Resize(cInd + 1, 5).Value = cArr
WS2.Range("A1:E1").Copy Destination:=ws3.Range("A1")
WS2.Range("A1:E1").Copy Destination:=ws4.Range("A1")
MsgBox ("Completato (" & Format(Timer - mytim, "0.00 Sec)"))
'
'Application.Calculation = xlCalculationAutomatic  '<<<< ripristina il calcolo
'Application.ScreenUpdating = True   '<<<< ripristina l'aggiornamento schermate
End Sub

Prova e fai sapere...
Avatar utente
Anthony47
Moderatore
 
Post: 19196
Iscritto il: 21/03/06 16:03
Località: Ivrea

Re: incolonnare dati con condizione

Postdi luca62 » 05/09/16 06:57

velocissima!..ma mi da qualche problema,
infatti , andando a sostituire il vecchio compila col nuovo:
sul foglio Ordini colonna e foglio Commerciali , mi appare la2^ riga vuota e soprattutto, mi copia e (cosa che non voglio) anche
la seconda riga dal foglio riepilogo ordini.
Inoltre l'indicazione del tempo ..0,11 sec!! devo levarla
grazie

Ps...non ti devi mai scusare!
riallego il file con inserita Compilaz al posto della vecchia Compila
http://www.filedropper.com/com5016_1
luca62 office2007 window7
luca62
Utente Senior
 
Post: 173
Iscritto il: 23/12/12 14:54

Re: incolonnare dati con condizione

Postdi Anthony47 » 06/09/16 01:52

C'erano un paio di subdoli errori nel codice, che quindi rettifico:
Codice: Seleziona tutto
Sub CompilAz()
Dim WArr, myRan As Range, OArr(), pArr(), cArr, LBWA As Long, I As Long, J As Long
Dim jInd As Long, pInd As Long, cInd As Long

'Application.ScreenUpdating = False  '<<<< evita l'aggiornamento schermate (sfarfallio)
'Application.Calculation = xlManual '<<<< ferma il calcolo e velocizza la macro

Set ws1 = Worksheets("RIEPILOGO ORDINI")
Set WS2 = Worksheets("INCOLONNA")
Set ws3 = Worksheets("PARTICOLARI")
Set ws4 = Worksheets("COMMERCIALI")
uc1 = ws1.Cells(1, Columns.Count).End(xlToLeft).Column
WS2.Range("A2:Z" & Rows.Count).ClearContents
ws3.Range("A2:Z" & Rows.Count).Cells.ClearContents
ws4.Range("A2:Z" & Rows.Count).Cells.ClearContents
ur1 = ws1.Cells(Rows.Count, 1).End(xlUp).Row
ReDim OArr(1 To ur1 * Int(uc1 / 19), 1 To 19)
ReDim pArr(1 To ur1 * Int(uc1 / 19), 1 To 5)
ReDim cArr(1 To ur1 * Int(uc1 / 19), 1 To 5)
mytim = Timer
'
For ccr = 1 To uc1 - 4 Step 19
'    Set myRan = Cells(1, 1).Offset(0, (ccr - 1) * 19).Resize(1000, 19)
    ur1 = ws1.Cells(Rows.Count, 1).Offset(0, ccr - 1).End(xlUp).Row
    WArr = ws1.Cells(3, 1).Offset(0, (ccr - 1)).Resize(ur1, 19).Value
    LBWA = LBound(WArr, 1)
    For I = LBWA To UBound(WArr, 1)
        If WArr(I, LBWA + 2) <> 0 Then
            For J = LBWA To UBound(WArr, 2)
                OArr(jInd + 1, J) = WArr(I, J)
                If J < 6 Then
                    If WArr(I, LBWA + 3) > 0 And WArr(I, LBWA + 3) < 2000000 Then
                            pArr(pInd + 1, J) = WArr(I, J)
                            myp = True: myc = False
                    Else
                        cArr(cInd + 1, J) = WArr(I, J)
                        myc = True: myp = False
                    End If
                End If
            Next J
            jInd = jInd + 1
            If myp Then pInd = pInd + 1 Else cInd = cInd + 1
        End If
    Next I
Next ccr
WS2.Cells(2, 1).Resize(jInd + 1, 19).Value = OArr
ws3.Cells(2, 1).Resize(pInd + 1, 5).Value = pArr
ws4.Cells(2, 1).Resize(cInd + 1, 5).Value = cArr
WS2.Range("A1:E1").Copy Destination:=ws3.Range("A1")
WS2.Range("A1:E1").Copy Destination:=ws4.Range("A1")
MsgBox ("Completato (" & Format(Timer - mytim, "0.00 Sec)"))
'
'Application.Calculation = xlCalculationAutomatic  '<<<< ripristina il calcolo
'Application.ScreenUpdating = True   '<<<< ripristina l'aggiornamento schermate
End Sub

Se vuoi eliminare il messaggio basta eliminare la riga del MsgBox.
Per una visualizzazione corretta la colonna T di ORDINI deve essere formattata come "Testo".

Ciao
Avatar utente
Anthony47
Moderatore
 
Post: 19196
Iscritto il: 21/03/06 16:03
Località: Ivrea

Re: incolonnare dati con condizione

Postdi luca62 » 06/09/16 07:01

tutto ok, solo una domanda, purtroppo ho alcuni dati tipo 20000F o 20000V o 20000M, ossia un numero
con massimo 5 cifre e una lettera accanto (F o M o V) che dovrei inserire comunque nei "PARTICOLARI"


For I = LBWA To UBound(WArr, 1)
If WArr(I, LBWA + 2) <> 0 Then
For J = LBWA To UBound(WArr, 2)
OArr(jInd + 1, J) = WArr(I, J)
If J < 6 Then
If WArr(I, LBWA + 3) > 0 And WArr(I, LBWA + 3) < 200000 Then
pArr(pInd + 1, J) = WArr(I, J)
myp = True: myc = False

come faccio a dirglielo? (con la macro vecchia, non so perchè riuisciva a capire che il 20000F o M o V era comunque inferiore a 200000

grazie ancora
luca62 office2007 window7
luca62
Utente Senior
 
Post: 173
Iscritto il: 23/12/12 14:54

Re: incolonnare dati con condizione

Postdi Anthony47 » 06/09/16 22:50

Dovrebbe bastare modificare la riga dopo If J < 6 Then:
Codice: Seleziona tutto
                If J < 6 Then
                    If WArr(I, LBWA + 3) > 0 And Val(WArr(I, LBWA + 3)) < 2000000 Then   '<<< MODIFICATA


Ciao
Avatar utente
Anthony47
Moderatore
 
Post: 19196
Iscritto il: 21/03/06 16:03
Località: Ivrea

Re: incolonnare dati con condizione

Postdi luca62 » 07/09/16 06:52

tutto perfetto adesso grazie ancora!
luca62 office2007 window7
luca62
Utente Senior
 
Post: 173
Iscritto il: 23/12/12 14:54

Re: incolonnare dati con condizione

Postdi luca62 » 07/09/16 07:07

adesso ho velocizzato !
una domanda, nel file che avevo allegato vi è questa macro che mi apre tutti i fogli tranne gli ultimi 8:
"Sub aggiornainsiemi()
'
' aggiornainsiemi Macro
' aggiorna i singoli fogli aprendoli prima di copiarli su riepologo ordini
'
For I = 1 To ThisWorkbook.Worksheets.Count - 8
Worksheets(I).Select
Next I
Worksheets(1).Select
End Sub

Aprendo ogni foglio (sono 32 o 50 in altri file), fa partire un codice che
permette di compilare il folgio stesso andando aprendere dati da file chiusi.
Spesso di questi 32 o 50 fogli) in realtà ne avrei da riaprire e aggiornare solo 1.
il codice di tutti i fogli è il seguente:

Codice: Seleziona tutto
Private Sub Worksheet_Activate()
ActiveSheet.Unprotect
Dim myBase(1 To 10)
myBase(1) = "'H:\produzione\distinta insiemi\[ZCZCX'!A3"
myBase(2) = "'H:\produzione\distinta insiemi\[ZCZCX'!C3"
myBase(3) = "'H:\produzione\distinta insiemi\[ZCZCX'!B3"
myBase(4) = "'H:\produzione\distinta insiemi\[ZCZCX'!D3"
myBase(6) = "'H:\produzione\distinta insiemi\[ZCZCX'!F3"
myBase(7) = "'H:\produzione\distinta insiemi\[ZCZCX'!G3"
myBase(8) = "'H:\produzione\distinta insiemi\[ZCZCX'!H3"
myBase(9) = "'H:\produzione\distinta insiemi\[ZCZCX'!I3"
myBase(10) = "'H:\produzione\distinta insiemi\[ZCZCX'!J3"




'Check esistenza file:
mySplit = Split(myBase(1), "[")
    mySplit1 = Split(Range("$A$1").Value, "]")
    myFile = Replace(mySplit(0), "'", "") & Replace(mySplit1(0), "[", "")
If Len(Dir(myFile)) = 0 Then
    MsgBox ("il file " & myFile & " non esiste" & vbCrLf & _
        "Le formule non sono state alterate")
    Exit Sub
End If
'
Application.EnableEvents = False
LastA = Cells(Rows.Count, 1).End(xlUp).Row
For I = 1 To 4
    Cells(3, 1 + I).Resize(LastA - 3, 1).FormulaLocal = "=" & Replace(myBase(I), "[ZCZCX", Range("$A$1").Value)


Next I
For I = 6 To 10
    Cells(3, 1 + I).Resize(LastA - 3, 1).FormulaLocal = "=" & Replace(myBase(I), "[ZCZCX", Range("$A$1").Value)
 Next I
 
Application.EnableEvents = True
ActiveSheet.Name = Left([D2] & " " & [C2], 20)
ActiveSheet.Protect

End Sub







c è modo ad inizio macro di dire di andare ad riscrivere i dati solo se il file dal quale vado a pescare
i nuovi dati ha una data di salvataggio posteriore alla data di salvataggio del file su cui sto lavorando?
(archivio ordini) ? o in alternativa poter velocizzare questo codice?
grazie ancora
luca62 office2007 window7
luca62
Utente Senior
 
Post: 173
Iscritto il: 23/12/12 14:54

Re: incolonnare dati con condizione

Postdi Anthony47 » 07/09/16 12:31

Ma il file a cui quelle formule fanno riferimento e' sempre lo stesso per tutti i fogli o sono file diversi? Perche' in questo caso la cosa piu' semplice e' aprire il file presente su H:\produzione\distinta insiemi\, aspettare pochi secondi che tutti i collegamenti si aggiornano, e richiuderlo.
Inserire formule che fanno riferimento a file chiusi va bene per pochi collegamenti da aggiornare, e mi pare che gia' te ne sei reso conto.
Avatar utente
Anthony47
Moderatore
 
Post: 19196
Iscritto il: 21/03/06 16:03
Località: Ivrea

Re: incolonnare dati con condizione

Postdi luca62 » 08/09/16 06:27

effettivamente sono n file su cuiii vado a pescare i dati, dovrei cercare di velocizzare il codice
luca62 office2007 window7
luca62
Utente Senior
 
Post: 173
Iscritto il: 23/12/12 14:54


Torna a Applicazioni Office Windows


Topic correlati a "incolonnare dati con condizione":


Chi c’è in linea

Visitano il forum: Marius44 e 42 ospiti