| | Post: 681 | Registrato il: 28/12/2009
| Città: CITTADELLA | Età: 62 | Utente Senior | excel 2007/365 | | OFFLINE | |
|
  16/11/2016 22:32 | |
Ciao a tutti.
Nel workbook allegato ci sono tre fogli, il foglio3 è collegato al foglio1/2.
E' possibile il foglio3 collegarlo al foglio1/2 con righe sfalsate?
Nel workbook c'è l'esempio.
Spero di essermi spiegagato.
Grazie in anticipo.
max
____________________________
versione excel 365 ufficio
versione excel 2007 casa |
|
| | Post: 2.483 | Registrato il: 03/04/2013
| Utente Veteran | Excel 2000 - 2013 | | OFFLINE | |
|
| 17/11/2016 10:14 | |
Buona giornata, Max;
posso proporti questo Codice VBA, da eseguire nel Foglio di lavoro "Foglio3"
Option Explicit
Sub Aggiorna()
Application.ScreenUpdating = False
Dim NrcX As Long, Nrc As Long, x As Long
Nrc = Range("A" & Rows.Count).End(xlUp).Row
If Nrc < 2 Then Nrc = 2
Range(Cells(2, 1), Cells(Nrc, 5)).ClearContents
With Worksheets("Foglio1")
NrcX = .Range("A" & Rows.Count).End(xlUp).Row
Nrc = 2
For x = 2 To NrcX
Range(.Cells(x, 1), .Cells(x, 5)).Copy
Cells(Nrc, 1).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
Nrc = Nrc + 2
Next x
End With
With Worksheets("Foglio2")
NrcX = .Range("A" & Rows.Count).End(xlUp).Row
Nrc = 3
For x = 2 To NrcX
Range(.Cells(x, 1), .Cells(x, 5)).Copy
Cells(Nrc, 1).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
Nrc = Nrc + 2
Next x
End With
Application.CutCopyMode = False
Application.ScreenUpdating = True
Cells(2, 1).Select
End Sub
A disposizione.
Buon Lavoro e buona serata.
Giuseppe
Windows XP - Excel 2000
Windows 10 - Excel 2013 |
| | Post: 681 | Registrato il: 28/12/2009
| Città: CITTADELLA | Età: 62 | Utente Senior | excel 2007/365 | | OFFLINE | |
|
| 17/11/2016 20:01 | |
Grazie giuseppe è o.k. ![[SM=g27811]](https://im0.freeforumzone.it/up/0/11/10151015.gif)
Un saluto.
max ____________________________
versione excel 365 ufficio
versione excel 2007 casa |
| | Post: 441 | Registrato il: 02/08/2015
| Utente Senior | Excel 2013 | | OFFLINE |
|
| 18/11/2016 09:04 | |
Ciao a tutti,
un'alternativa (lato formule) all'ottima soluzione di Giuseppe (un saluto)...
Nella cella A2 del "Foglio3" (da copiare poi a destra ed in basso):
=INDIRETTO(SCEGLI(VAL.PARI(RIF.RIGA())+1;"Foglio2";"Foglio1")&"!"&INDIRIZZO(INT(RIF.RIGA()/2)+1;RIF.COLONNA()))
Ti riallego il file a scanso di equivoci...
"Sono le persone che nessuno immagina che possano fare certe cose, quelle che fanno cose che nessuno può immaginare." |
| | Post: 684 | Registrato il: 28/12/2009
| Città: CITTADELLA | Età: 62 | Utente Senior | excel 2007/365 | | OFFLINE | |
|
| 18/11/2016 20:10 | |
Ciao giuseppe.
La tua macro funziona per il range che ho inserito in #1
E' possibile modificare la macro (mi sono perso) per il nuovo range del workbook allegato?
riga3 foglio "dividi" nella riga2 foglio "unito"
riga3 foglio "descrizione" nella riga3 foglio "unito"
riga4 foglio "dividi" nella riga4 foglio "unito"
riga4 foglio "descrizione" nella riga5 foglio "unito"
riga5 foglio "dividi" nella riga6 foglio "unito"
riga5 foglio "descrizione" nella riga7 foglio "unito"
ecc...
max ____________________________
versione excel 365 ufficio
versione excel 2007 casa |
| | Post: 2.484 | Registrato il: 03/04/2013
| Utente Veteran | Excel 2000 - 2013 | | OFFLINE | |
|
| 18/11/2016 21:51 | |
Buona sera, Max;
consentimi un saluto a @ cromagno (Buona serata, Tore; ottima la Tua Soluzione!)
Tornado a noi, Max, potresti provare il Codice VBA:
Option Explicit
Sub Aggiorna()
Application.ScreenUpdating = False
Dim NrcX As Long, NrC As Long, Cln As Long, x As Long
NrC = Range("A" & Rows.Count).End(xlUp).Row
Cln = Cells(1, Columns.Count).End(xlToLeft).Column
If NrC < 2 Then NrC = 2
Range(Cells(2, 1), Cells(NrC, Cln)).ClearContents '<<< 2,1 = A1 5=E
With Worksheets("dividi") '<<< nome foglio
Cln = .Cells(2, Columns.Count).End(xlToLeft).Column
NrcX = .Range("A" & Rows.Count).End(xlUp).Row
NrC = 2
For x = 3 To NrcX
Range(.Cells(x, 1), .Cells(x, Cln)).Copy
Cells(NrC, 1).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
NrC = NrC + 2
Next x
End With
With Worksheets("descrizione")
Cln = .Cells(2, Columns.Count).End(xlToLeft).Column
NrcX = .Range("A" & Rows.Count).End(xlUp).Row
NrC = 3
For x = 3 To NrcX
Range(.Cells(x, 1), .Cells(x, Cln)).Copy
Cells(NrC, 1).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
NrC = NrC + 2
Next x
End With
Application.CutCopyMode = False
Application.ScreenUpdating = True
Cells(2, 1).Select
End Sub
A disposizione.
Buona serata.
Giuseppe
Windows XP - Excel 2000
Windows 10 - Excel 2013 |
| | Post: 2.486 | Registrato il: 03/04/2013
| Utente Veteran | Excel 2000 - 2013 | | OFFLINE | |
|
| 18/11/2016 21:57 | |
Solo una precisazione: '<<< 2,1 = A1 5=E se ho interpretato correttamente la TUa intenzione, non credo sia esattamente così; ma: '<<< 2,1 = A2 5=E Giuseppe
Windows XP - Excel 2000
Windows 10 - Excel 2013 |
| | Post: 686 | Registrato il: 28/12/2009
| Città: CITTADELLA | Età: 62 | Utente Senior | excel 2007/365 | | OFFLINE | |
|
| 18/11/2016 23:10 | |
Ciao giuseppe,
la seconda macro non incolla come chiedevo.
Dopo molte modifiche ho modificato la prima macro così:
Option Explicit
Sub Aggiorna()
Application.ScreenUpdating = False
Dim NrcX As Long, NrC As Long, x As Long
NrC = Range("A" & Rows.Count).End(xlUp).Row
If NrC < 2 Then NrC = 3
Range(Cells(2, 1), Cells(NrC, 18)).ClearContents '<<< 2,1 = A1 5=E
With Worksheets("dividi") '<<< nome foglio
NrcX = .Range("A" & Rows.Count).End(xlUp).Row
NrC = 3 '<< copia in riga 2
For x = 3 To NrcX '<<< parte da riga 3
Range(.Cells(x, 1), .Cells(x, 18)).Copy
Cells(NrC, 1).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
NrC = NrC + 2
Next x
End With
With Worksheets("descrizione")
NrcX = .Range("A" & Rows.Count).End(xlUp).Row
NrC = 4 '<<< copia in riga 3
For x = 3 To NrcX '<<< parte da riga 3
Range(.Cells(x, 1), .Cells(x, 18)).Copy
Cells(NrC, 1).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
NrC = NrC + 2
Next x
End With
Application.CutCopyMode = False
Application.ScreenUpdating = True
Cells(2, 1).Select
End Sub
che gira bene per la mia seconda richiesta.
Mi puoi scrivere nella macro quali sono le righe che copia?
max ____________________________
versione excel 365 ufficio
versione excel 2007 casa |
| | Post: 2.487 | Registrato il: 03/04/2013
| Utente Veteran | Excel 2000 - 2013 | | OFFLINE | |
|
| 19/11/2016 05:20 | |
Buona giornata, Max;
l'unica differenza che posso rilevare tra il Tuo Codice VBA e quello proposto in Risposta #6 è nella definizione delle Colonne da considerare nei Range da copiare.
Nel Tuo Codice VBA è definito in 18 Colonne a prescindere; nel mio Codice VBA il numero delle Colonne è calcolato con la Variabile "Cln".
Questo tipo di soluzione, nel mio Codice VBA, consente di poter gestire l'aggiunta di eventuali ulteriori "Campi" (Colonne) nei tre Fogli di lavoro.
Prendendo ad esmpio il Tuo File proposto in #5, le Colonne calcolate sono 18 nel Foglio di lavoro "dividi" mentre, nel Foglio di lavoro "descrizione", avremo una sola Colonna.
Riporto il Codice VBA con i commenti a margine delle istruzioni.
Option Explicit
Sub Aggiorna()
Application.ScreenUpdating = False
Dim NrcX As Long, NrC As Long, Cln As Long, x As Long ' Definisce le Variabili
NrC = Range("A" & Rows.Count).End(xlUp).Row ' Righe da considerare in "unito"
Cln = Cells(1, Columns.Count).End(xlToLeft).Column ' Colonne da considerare in "unito"
If NrC < 2 Then NrC = 2
Range(Cells(2, 1), Cells(NrC, Cln)).ClearContents '<<< 2,1 = A2 Cln = R (Cln = 18)
With Worksheets("dividi") '<<< nome foglio
Cln = .Cells(2, Columns.Count).End(xlToLeft).Column ' Colonne da considerare in "dividi"
NrcX = .Range("A" & Rows.Count).End(xlUp).Row ' Righe da considerare in "dividi"
NrC = 2 ' Definisce la Riga da cui partire in "unito"
For x = 3 To NrcX ' 3 = Riga da cui partire in "dividi"
Range(.Cells(x, 1), .Cells(x, Cln)).Copy ' Definisce il Range da copiare (Cln = 18)
Cells(NrC, 1).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False ' Incolla "Valori" in "unito"
NrC = NrC + 2 ' Incremento in "unito"
Next x
End With
With Worksheets("descrizione") ' Nome Foglio di lavoro
Cln = .Cells(2, Columns.Count).End(xlToLeft).Column ' Colonne da considerare in "descrizione"
NrcX = .Range("A" & Rows.Count).End(xlUp).Row ' Righe da considerare in "descrizione"
NrC = 3 ' Definisce la Riga da cui partire in "unito"
For x = 3 To NrcX ' 3 = Riga da cui partire in "descrizione"
Range(.Cells(x, 1), .Cells(x, Cln)).Copy ' Definisce il Range da copiare (Cln = 1)
Cells(NrC, 1).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False ' Incolla "Valori" in "unito"
NrC = NrC + 2 ' Incremento in "unito"
Next x
End With
Application.CutCopyMode = False ' Dichiara la fine del "Copia"
Application.ScreenUpdating = True
Cells(2, 1).Select ' Posiziona il Cursore in Cella "A2"
End Sub
Allego il File con il quale ho eseguito i miei Test.
A disposizione.
Buona serata.
Giuseppe
Windows XP - Excel 2000
Windows 10 - Excel 2013 |
|
|
|
|