-
Articoli
-
Buongiorno a tuti,
Premesso che ho diversi fogli di excel sullo stesso file e su ciascuno di essi voglio che venga eseguita questa macro
Sub Macro2() ' ' Macro2 Macro ' ' Range("N2").Select Range(Selection, Selection.End(xlDown)).Select Range("N2:O100").Select Selection.Copy Range("T2").Select Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _ :=False, Transpose:=False Range("P2").Select Range(Selection, Selection.End(xlDown)).Select Range("P2:Q100").Select Application.CutCopyMode = False Selection.Copy Range("T101").Select Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _ :=False, Transpose:=False Range("T2").Select Range(Selection, Selection.End(xlDown)).Select Range("T2:U199").Select Application.CutCopyMode = False ActiveWorkbook.Worksheets("2 giornata").Sort.SortFields.Clear ActiveWorkbook.Worksheets("2 giornata").Sort.SortFields.Add Key:=Range( _ "T2:T199"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:= _ xlSortNormal ActiveWorkbook.Worksheets("2 giornata").Sort.SortFields.Add Key:=Range( _ "U2:U199"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:= _ xlSortNormal With ActiveWorkbook.Worksheets("2 giornata").Sort .SetRange Range("T2:U199") .Header = xlGuess .MatchCase = False .Orientation = xlTopToBottom .SortMethod = xlPinYin .Apply End With End SubPero ovviamente questa macro vinee eseguita solo nel foglio in cui l'ho creata e non su tutti gli altri fogli.
Esiste un modo perche tale macro una volta attivata funziona su tutt i fogli del file oppure per ogni foglio devo creare la mascro?
Grazie a chi mi aiuta
Luigi
Per eseguire la macro in un sol colpo su tutti i fogli occorre un ciclo For.
la tua macro però, probabilmente registrata, va completamente rivista.
Se alleghi un file con dati e risultato da ottenere (per un foglio) possiamo vedere di aggiustare
Ciao Luigi, prova ad allegare un file che rispetti la stessa struttura e in base ad esso spiega meglio il risultato da ottenere. Da un primo sguardo ciò che tenti di fare con questa macro sembra che tu voglia copiare ed incollare dei valori e poi applicare degli ordinamenti.
Servirebbe il file per le relative prove.
P.S. scusa alfrimpa ma non ho notato il tuo intervento.
Ok, intanto grazie per le risposte
Vi allego il file
in pratica ad esclusione del foglio 1, in tutti gli altri fogli deve copiare gli intervalli N2: N100 e P2:P100 e incollarli nella colonna T a partire dalla cella T2 e gli intervalli O2: O100 e Q2:Q100 e incollarli nella colonna U a partire dalla cella U2, in modo di avere nella colonna T i dati che ho nelle colonne N e P e nella colonna U i dati che ho nelle colonne O e Q.
Fatto questo deve mettermeli in ordine alfabetico con inizio la cella T2
Grazie ancora
Luigi
Ciao Verbo
Prima di eseguire la macro che vedi devi nella cella T1 di ogni foglio scrivi qualcosa (anche una semplice lettera l'importante è che la cella T1 non sia vuota)
poi nel codice alla settima riga devi cambiare la lettera N con la C.
Sub copiaOrdina() Dim i As Integer Dim j As Integer Dim ur As Long Dim uriga Dim lr As Long ur = Cells(Rows.Count, "N").End(xlUp).Row Application.ScreenUpdating = False For i = 2 To Sheets.Count Sheets(i).Range("T2:T1000").ClearContents For j = 14 To 16 Step 2 lr = Sheets(i).Cells(Rows.Count, "T").End(xlUp).Row Range(Sheets(i).Cells(2, j), Sheets(i).Cells(ur, j)).Copy Sheets(i).Cells(lr + 1, "T").PasteSpecial Paste:=xlPasteValues Next j uriga = Cells(Rows.Count, "T").End(xlUp).Row Sheets(i).Sort.SortFields.Clear Sheets(i).Sort.SortFields.Add2 Key:=Range( _ "T2:t" & uriga), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:= _ xlSortNormal With Sheets(i).Sort .SetRange Range("T2:T" & uriga) .Header = xlGuess .MatchCase = False .Orientation = xlTopToBottom .SortMethod = xlPinYin .Apply End With Next i Application.ScreenUpdating = True MsgBox "Operazione completata" End SubCiao Alf,
intanto grazie per l'attenzione prestatami
ho copiato la tua macro ma quando l'attivo
mi compare la scritta
Errore di run -time '438'
Proprietà o metodo non supportati dall'oggetto e se clicco su debug
la parte evidenziata in giallo è la seguente
Sheets(i).Sort.SortFields.Add2 Key:=Range( _
"T2:t" & uriga), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:= _
xlSortNormalCome posso risolvere?
un'ultima cosa
è possibile far si che l'operazione avvenga contemporaneamente ante su tutti i fogli tranne che nel primo?
Ti riallego il file dove ho copiato la macro da te suggerita
copiare gli intervalli N2: N100 e P2:P100 e incollarli nella colonna T a partire dalla cella T2 e gli intervalli O2: O100 e Q2:Q100
Scusa, ma su alcuni fogli le colonne O e P mi sembrano vuote e su altri la colonna N ha già il valore che dovrebbe essere in colonna O (p.e.: foglio "3 giornata" colonne O e Q vuote e cella N2 "CHIODI Teresio ALE" e P2 "SCANSETTI Egidio NOV".
Puoi allegare un file, anche con solo 4 fogli ma coerenti e senza ambiguità?
Ciao Scossa.
nel foglio "3 giornata" c'era un errore di formule nelle colonne O e Q
si il valore delle colonna O e Q e in parte nelle colonne N e P
Io devo poi copiare in sequenza le colonne N e P cosi come sono in T e U
e dopo l'ultimo nominativo della colonna N riportato nella colonna T devo copiare sempre in T i nominativi della colonna P
In questo modo i nominativi che ho in N e P devono risultare su unica colonna T e metterli in ordine alfabetico.
Allego il file in cui ho corretto il foglio "3 giornata" ed eliminato altri foglio come mi hai consigliato
Ciao @verbo, hai un po' di cose da sistemare nel file. Alcune celle hanno formule con riferimenti sbagliati soprattutto verso gli ultimi foglio, quindi devi prima sistemarli.
Fatto ciò, prova questo codice. Ho cercato di renderlo quanto più robusto possibile (ma penso sia nettamente migliorabile). Questo perché non conosco come valorizzi i le varie celle. Ecco perché ricalcolo ogni volta tutte le colonne interessate:
Option Explicit Sub consolida() Dim ws As Worksheet Dim i As Long Dim urN As Long, urP As Long, urO As Long, urQ As Long Dim lastT As Long, lastU As Long Application.ScreenUpdating = False Application.Calculation = xlCalculationManual For i = 1 To ThisWorkbook.Worksheets.Count Set ws = ThisWorkbook.Worksheets(i) If ws.Name <> "Foglio1" Then ws.Range("T2:T1000").ClearContents ws.Range("U2:U1000").ClearContents '================= Colonna T ================= urN = ultimaCella("N", ws) If urN > 1 Then ws.Range("T2:T" & urN).Value2 = ws.Range("N2:N" & urN).Value2 End If urP = ultimaCella("P", ws) If urP > 1 Then lastT = ws.Cells(Rows.Count, "T").End(xlUp).Row ws.Range("T" & lastT + 1 & ":T" & lastT + urP - 1).Value = ws.Range("P2:P" & urP).Value2 End If lastT = ws.Cells(Rows.Count, "T").End(xlUp).Row If lastT >= 3 Then ws.Range("T2:T" & lastT).Sort Key1:=ws.Range("T2"), _ Order1:=xlAscending, Header:=xlNo, Orientation:=xlTopToBottom End If '================= Colonna U ================= urO = ultimaCella("O", ws) If urO > 1 Then ws.Range("U2:U" & urO).Value2 = ws.Range("O2:O" & urO).Value2 End If urQ = ultimaCella("Q", ws) If urQ > 1 Then lastU = ws.Cells(Rows.Count, "U").End(xlUp).Row ws.Range("U" & lastU + 1 & ":U" & lastU + urQ - 1).Value = ws.Range("Q2:Q" & urQ).Value End If lastU = ws.Cells(Rows.Count, "U").End(xlUp).Row If lastU >= 3 Then ws.Range("U2:U" & lastU).Sort Key1:=ws.Range("U2"), _ Order1:=xlAscending, Header:=xlNo, Orientation:=xlTopToBottom End If End If Next i Application.Calculation = xlCalculationAutomatic Application.ScreenUpdating = True MsgBox "Finito!" End Sub Function ultimaCella(colonna As String, ws As Worksheet) As Long Dim sh As Worksheet Dim i As Long On Error GoTo GestError Set sh = ws For i = sh.Cells(sh.Rows.Count, colonna).End(xlUp).Row To 1 Step -1 If Len(Trim(sh.Cells(i, colonna).Value)) > 0 Then ultimaCella = i Exit Function End If Next i ultimaCella = 0 Exit Function GestError: MsgBox "Errore nr. " & Err.Number & " - " & Err.Description, vbCritical, "Errore in ultimaCella" ultimaCella = -1 End FunctionAllego il file in cui ho corretto il foglio "3 giornata" ed eliminato altri foglio come mi hai consigliato
Per capire, visto che il file ha estensione .xls, che versione di Excel hai?
La versione è EXCEL 97-2003
Scusa Alex quando dici
Ciao @verbo, hai un po' di cose da sistemare nel file. Alcune celle hanno formule con riferimenti sbagliati soprattutto verso gli ultimi foglio, quindi devi prima sistemarli.
Fatto ciò, prova questo codice. Ho cercato di renderlo quanto più robusto possibile (ma penso sia nettamente migliorabile). Questo perché non conosco come valorizzi i le varie celle. Ecco perché ricalcolo ogni volta tutte le colonne interessate:
Cosa intendi con riferimenti sbagliati?
Se puoi spiegarmelo in modo semplice perchè come avrai capito sono abbastanza ignorante in materia di informatica
deve copiare gli intervalli N2: N100 e P2:P100 e incollarli nella colonna T a partire dalla cella T2 e gli intervalli O2: O100 e Q2:Q100 e incollarli nella colonna U a partire dalla cella U2, in modo di avere nella colonna T i dati che ho nelle colonne N e P e nella colonna U i dati che ho nelle colonne O e Q.
Per questa parte prova il seguente codice:
Sub Elabora() Dim wb As Workbook, ws As Worksheet Dim rng1 As Range, rng2 As Range Dim nWsCnt As Long, nWs As Long Dim nLR1 As Long, nLR2 As Long Set wb = ThisWorkbook nWsCnt = wb.Worksheets.Count Application.ScreenUpdating = False For nWs = 2 To nWsCnt With wb.Worksheets(nWs) 'colonne N e P in T Set rng1 = .Range("N2:N100") nLR1 = fLstRw(rng1) Set rng2 = .Range("P2:P100") nLR2 = fLstRw(rng2) .Range("T2:T300").ClearContents .Range("U2:U300").ClearContents rng1.Offset(0, 6).Value = rng1.Value rng2.Offset(nLR1, 4).Value = rng2.Value 'colonne O e Q in U Set rng1 = .Range("O2:O100") nLR1 = fLstRw(rng1) Set rng2 = .Range("Q2:Q100") nLR2 = fLstRw(rng2) rng1.Offset(0, 6).Value = rng1.Value rng2.Offset(nLR1, 4).Value = rng2.Value End With Next nWs Application.ScreenUpdating = True Set rng1 = Nothing Set rng2 = Nothing Set wb = Nothing MsgBox "FINITO!" End Sub Private Function fLstRw(ByRef rRUT As Range) As Long Dim nLastRow As Long On Error Resume Next nLastRow = Evaluate("=SUM(--(SUBSTITUTE(" & rRUT.Address(, , , 1) & ","" "","""")>"" ""))") '<--- modificata On Error GoTo 0 nLastRow = IIf(nLastRow = 0, 1, nLastRow) Set rRUT = rRUT.Resize(nLastRow) fLstRw = nLastRow End FunctionN.B.: corretta udf: aggiunta gestione dell'errore per le celle con #RIF! e usato indirizzo completo.
Cosa intendi con riferimenti sbagliati?
Nel foglio "31 giornata" in cella "N7" c'è scritto: =CONCATENA(#RIF!;" ";B7;" ";$E$2) così come anche in altre celle nelle stesso fogli ed anche nei fogli successivi.
Poi in tutti i fogli, nelle colonne "O" e "Q" c'è scritto =CONCATENA($E$2) e =CONCATENA($F$2)
Ma non basta semplicemente in "O" =$E$2 e in "Q" =$F$2?
Hai provato il codice proposto?
Aggiungo che da riga143 colonna P, riiniziano varie formule
Ps. Ieri sera sono diventato matto a creare il VBA della formula per calcolare l'ultima riga, dato che ci sono vari concatena che creano tre spazi. Finalmente oggi ci sono riuscito...=MATR.SOMMA.PRODOTTO((N2:N200<>"")*(N2:N200<>"***"))+1 NB Il forum elimina spazi... (*) = spazio
Sub ULTIMA_RIGA() Dim Ur As Long, TOT As Long Ur = Range("N" & Rows.Count).End(xlUp).Row TOT = Evaluate("=SUMPRODUCT((N1:N" & Ur & "<>"""")*(N1:N" & Ur & "<>"" ""))") + 1 'causa N1 vuota MsgBox TOT End SubCodice completo con anche l'ordinamento delle colonne T e U:
Sub Elabora() Dim wb As Workbook, ws As Worksheet Dim rng1 As Range, rng2 As Range Dim nWsCnt As Long, nWs As Long Dim nLR1 As Long, nLR2 As Long Set wb = ThisWorkbook nWsCnt = wb.Worksheets.Count Application.ScreenUpdating = False Application.Calculation = xlCalculationManual For nWs = 2 To 31 'nWsCnt Set ws = wb.Worksheets(nWs) With ws 'colonne N e P in T .Range("T2:T300, U2:U300").ClearContents Set rng1 = .Range("N2:N100") nLR1 = fLstRw(rng1) If nLR1 > 0 Then rng1.Offset(0, 6).Value = rng1.Value End If Set rng2 = .Range("P2:P100") nLR2 = fLstRw(rng2) rng2.Offset(nLR1, 4).Value = rng2.Value Set rng1 = .Range("O2:O100") nLR1 = fLstRw(rng1) rng1.Offset(0, 6).Value = rng1.Value Set rng2 = .Range("Q2:Q100") nLR2 = fLstRw(rng2) rng2.Offset(nLR1, 4).Value = rng2.Value Set rng1 = .Range("T2:T500") nLR1 = fLstRw(rng1) If nLR1 > 1 Then rng1.Sort Key1:=rng1.Cells(1, 1), _ Order1:=xlAscending, Header:=xlNo, Orientation:=xlTopToBottom End If Set rng2 = .Range("U2:U500") nLR2 = fLstRw(rng2) If nLR2 > 1 Then rng2.Sort Key1:=rng2.Cells(1, 1), _ Order1:=xlAscending, Header:=xlNo, Orientation:=xlTopToBottom End If End With Next nWs Application.Calculation = xlCalculationAutomatic Application.ScreenUpdating = True Set rng1 = Nothing Set rng2 = Nothing Set wb = Nothing Set ws = Nothing MsgBox "FINITO!" End Sub Private Function fLstRw(ByRef rRUT As Range) As Long Dim nLastRow As Long On Error Resume Next nLastRow = Evaluate("=SUM(--(SUBSTITUTE(" & rRUT.Address(, , , 1) & ","" "","""")>"" ""))") On Error GoTo 0 nLastRow = IIf(nLastRow = 0, 1, nLastRow) Set rRUT = rRUT.Resize(nLastRow) fLstRw = nLastRow End FunctionCiao scusate il ritardo
grazie a ttuti quelli a cui ho rotto le scatole per la pazienza accordatami
Un grazie particolar ea scossa la tua ultima macro funziona alla grnadissima e fa proprio ciò che volevo facesse.
Grazie ad Alex per i l tempo dedicatomi e che mi ha insegnato una nuova cosa pensavo che per copiare una cella in altra cella era necessario scrivere concatena.
Grazie a tutti
ciao,
tanto per esercizio altra soluzione, tenendo conto che
- come già segnalato hai dei #RIF in alcune elle che vanno sistemati
- la sub è "rigida" in quanto considera solo fiino a riga 89. questo perchè da riga 90 hai alcune celle riempite con uno spazio e non vuote. Per rendere più flessibile la sub (quindi calcorare l'ultima cella piena, e non 89 fisso) bisognerebbe prima pulire queste celle
la sub porta i dati da N e P in T e li ordina
Sub CopyPasteFogli() Dim i As Integer Worksheets(2).Select For i = 2 To Worksheets.Count Worksheets(i).Select Replace:=False Next i Range("N2:N89").Copy Range("T2").PasteSpecial Paste:=xlPasteValues Range("P2:P89").Copy Range("T90").PasteSpecial Paste:=xlPasteValues For i = 2 To Worksheets.Count With Worksheets(i).Range("T2:T177") .Sort Key1:=Worksheets(i).Range("T2"), Order1:=xlAscending, _ Orientation:=xlTopToBottom, Header:=xlNo End With Next i End Sub
Ciao,
intanto grazie per quello che hai fatto.
Quindi mi sta dicendo che se vengono interessate anche le celle successive alla 89 devo prima attivare la tua macro?
Quindi devo prima attivare la tua macro e poi quella di scossa?
ciao,
no la macro è "rigida" se vengono aggiunte nuove righe non vengono considerate. Se invece hai un file senze celle riempite con spazi basta una piccola modifica alla sub per prendere tutte le righe presenti
Cosa intendi per celle riempite con spazi
i ad es le celle N90 : N100 non sono vuote ma concengono uno spazio (" ", coduce 32). Questo fa si che l'istruzione per trovare lèultima riga piena considera anche le celle con " "
Domanda: le righe (i nomi) nei vari fogli sono sempre uguali? adesso sono 88 fossero 100 sarebbero 100 in tutti i fogli?
Alex ciao scusa non l'ho ancora provata
ti aggiorno
Luke i nomi nei vari fogli si ora sono 88 ma possono aumentare anche oltre i 100.
Ok capita la storia delle celle non vuote nel senso che appunto è vuota in quel caso ma potrebbe riempirsi io al momento non lo so, ma posso saperlo quando inizio a riempire il primo foglio perchè se il primo foglio ha ad esempio 90 nomi tutti i successivi fogli avranno 90 nomi.
Login
Registrati
