Copia dati da un foglio all'altro in Base ad una condizione

[DodiPartecipante Dodi Karma: 2 pts]

Buonasera a tutti voi del Forum. Chiedo il vostro aiuto per risolvere un problema che mi attanaglia, vengo al dunque e alla mia necessità di risolvere questo problema, ammesso che sia fattibile. In pratica ho un file che utilizzo per la contabilità, dove ho un foglio Progressivo e un foglio SAL N°, sul foglio Progressivo faccio le contabilità in seguenza. dove nella colonna "E" scrivo il N° del SAL (stato avanzamento lavori); mentre il foglio SAL n° serve per avere un riepilogo per il solo N° di SAL che scrivo nella cella "S2" , quindi dovrei scrivere il riferimento del SAL prelevare tutte le righe di riferimento dal folgio progressivo e trascriverle sul foglio SAL N°. Vi faccio presente che tra i due fogli, l'incolonnamento e la struttura rimane la stessa, ad eccezzione la colonna (P.U. e Quantità), riferimento colonna "Q e R" nei due vogli sono invertiti. quindi bisogna tenere in considerazione qsta cosa, e cioè quando i dati del foglio progressivo vengono trasferiti al foglio SAL N° bisogna invertire l'ordine della Quantià e del P.U. prezzo unitario. Allego il file per farvi capire il risultato che dovrei ottenere.
Resto in attesa di vostro aiuto, ammesso che sia fattibile come cosa.

Allegati:

You must be logged in to view attached files.

[alexps81Moderatore alexps81 Karma: 58 pts]

Ciao @dodi

un esempio fatto molto rapidamente (quindi penso si posso migliorare ma il tempo a disposizione è stato poco), potrebbe essere questo codice:

Nell'evento Change del foglio "SAL N°" metti questo:

Option Explicit

Private Sub Worksheet_Change(ByVal Target As Range)
    Dim wsProg As Worksheet, wsSal As Worksheet
    Dim SAL As String
    Dim f As Range, nSAL As Range
    Dim uRow As Long, lastRow As Long, r As Long
    Dim i As Integer
    Dim firstAddress As String
    
    Set wsProg = ThisWorkbook.Worksheets("Progressivo")
    Set wsSal = ThisWorkbook.Worksheets("SAL N°")
    Set nSAL = wsSal.Range("S2")
    
    If Not Intersect(Target, nSAL) Is Nothing Then
        SAL = wsSal.Range("S2").Value
        uRow = wsSal.Cells(Rows.Count, "A").End(xlUp).Row
        If uRow <= 6 Then uRow = 7
        
        Application.ScreenUpdating = False
        Application.EnableEvents = False
        wsSal.Range("A7:S" & uRow).ClearContents
        lastRow = wsProg.Cells(Rows.Count, "A").End(xlUp).Row
        
        Set f = wsProg.Range("E11:E" & lastRow).Find(What:=SAL, After:=wsProg.Range("E11"), LookIn:=xlValues, LookAt:=xlWhole)
            
        If Not f Is Nothing Then
            r = 7
            firstAddress = f.Address
            Do
                For i = 1 To 16
                    wsSal.Cells(r, i).Value = wsProg.Cells(f.Row, i).Value
                Next i
                wsSal.Cells(r, 17).Value = wsProg.Cells(f.Row, 18).Value
                wsSal.Cells(r, 18).Value = wsProg.Cells(f.Row, 17).Value
                wsSal.Cells(r, 19).Value = wsProg.Cells(f.Row, 19).Value
                r = r + 1
                
                Set f = wsProg.Range("E11:E" & lastRow).FindNext(f)
            Loop While firstAddress <> f.Address
        End If
        Application.EnableEvents = True
        Application.ScreenUpdating = True
    End If
    
    Set f = Nothing
    Set nSAL = Nothing
    Set wsSal = Nothing
    Set wsProg = Nothing
End Sub

Poi prova a modificare il numero SAL nella cella S2 e vedi se fa quello che desideravi.

Fammi sapere...ciao

[DodiPartecipante Dodi Karma: 2 pts]

Alex 

buongiorno, ti ringrazio per il tuo codice, in prima battuta l'ho testato, 

il file di cui allegato è in Work Progres

quindi non appena ho completato il file ti tengo presente e ti aggiorno che il tutto gira in modo perfetto. 

intanto grazie mille, 

e se non ci sentiamo a tretto giro, Buon natale e buone feste

 

[DodiPartecipante Dodi Karma: 2 pts]

Ciao Alex

ho un piccolo problema, 

ho creato un tasto che mi fa la copia del foglio  SAL N per poi numerarlo 1, 2, 3 ecc ecc.. 

il tuo codice in questa striga 

If Not Intersect(Target, nSAL) Is Nothing Then

va in errore, perchè non riconosce più il nome del foglio, 

è possibile che se faccio una copia del foglio il codice non viene trascritto anche sul nuovo Foglio? 

spero di aver espresso bene il concetto e che sia capibile. 

ma per le vie brevi il tuo codice deve rimanere sempre e solo Nell'evento Change del foglio "SAL N°, 

quindi sulla nuovo foglio che numero in progressivo non ci sia nulla. 

spero di risolvere il mio problema. 

 

 

 

 

[alexps81Moderatore alexps81 Karma: 58 pts]

Ma tu vuoi che non ci sia proprio il codice nel nuovo foglio perché non ti serve averlo o perché pensi che averlo ti crea problemi allora poi cercherai di rimediare in altro modo?

Vorrei capire come mai crei un nuovo foglio identico a "SAL N°" ma che poi non deve funzionare come "SAL N°"

[DodiPartecipante Dodi Karma: 2 pts]

 Ciao Alex 

il foglio SAL N, lo uso di appoggio per estrarre i dati del foglio Progressivo, 

poi una volta estratto i dati di riferimento, creo un foglio con il nome SAL N° 1 e così via, 

nel nuovo foglio creato, poi accio raggruppare per articolo i dati estratti. avendo cosi un sommario per articoli. 

 

quindi il codice da te suggerito dovrebbe rimanere solo nella Change del foglio "SAL N°,

perchè sulla striga riportata su, va in errore non riconoscendo il nome del foglio.  e poi evito di portarmi dietro in ogno foglio creato un codice che poi non mi serve. 

 

[alexps81Moderatore alexps81 Karma: 58 pts]

Prova così e vedi se va meglio:

Nell'evento Change del Foglio "SAL N°" modifica la macro che ti ho fornito con questa (ci sono minime migliorie):

Option Explicit

Private Sub Worksheet_Change(ByVal Target As Range)
    Dim wsProg As Worksheet, wsSal As Worksheet
    Dim SAL As String
    Dim f As Range
    Dim uRow As Long, lastRow As Long, r As Long
    Dim i As Integer
    Dim firstAddress As String
    
    Set wsProg = ThisWorkbook.Worksheets("Progressivo")
        
    If Not Intersect(Target, Range("S2")) Is Nothing Then
        Set wsSal = ThisWorkbook.ActiveSheet
        SAL = wsSal.Range("S2").Value
        uRow = wsSal.Cells(Rows.Count, "A").End(xlUp).Row
        If uRow <= 6 Then uRow = 7
        
        Application.ScreenUpdating = False
        Application.EnableEvents = False
        wsSal.Range("A7:S" & uRow).ClearContents
        lastRow = wsProg.Cells(Rows.Count, "A").End(xlUp).Row
        
        Set f = wsProg.Range("E11:E" & lastRow).Find(What:=SAL, After:=wsProg.Range("E11"), LookIn:=xlValues, LookAt:=xlWhole)
            
        If Not f Is Nothing Then
            r = 7
            firstAddress = f.Address
            Do
                For i = 1 To 16
                    wsSal.Cells(r, i).Value = wsProg.Cells(f.Row, i).Value
                Next i
                wsSal.Cells(r, 17).Value = wsProg.Cells(f.Row, 18).Value
                wsSal.Cells(r, 18).Value = wsProg.Cells(f.Row, 17).Value
                wsSal.Cells(r, 19).Value = wsProg.Cells(f.Row, 19).Value
                r = r + 1
                
                Set f = wsProg.Range("E11:E" & lastRow).FindNext(f)
            Loop While firstAddress <> f.Address
        End If
        Application.EnableEvents = True
        Application.ScreenUpdating = True
    End If
    
    Set f = Nothing
    Set wsSal = Nothing
    Set wsProg = Nothing
End Sub

Mentre a quel tasto che hai creato a cui hai legato la macro che Copia/Incolla il foglio "SAL N°", ci leghi questa di macro:

Option Explicit

Sub creaCopiaFoglio()
    Dim wsOriginale As Worksheet
    Dim wsNuovo As Worksheet
    Dim nomeFoglioNuovo As Variant
    Dim ws As Worksheet
    Dim foglioEsistente As Boolean
    
    nomeFoglioNuovo = Application.InputBox("Inserisci il nome del nuovo Foglio", "Nome del nuovo Foglio", Type:=2)

    If nomeFoglioNuovo = False Then Exit Sub
                    
    For Each ws In ThisWorkbook.Worksheets
        If nomeFoglioNuovo = ws.Name Then
            foglioEsistente = True
            MsgBox "Nome Foglio già esistente", vbCritical
            Exit For
        End If
    Next ws
            
    If Not foglioEsistente Then
        Set wsOriginale = ThisWorkbook.ActiveSheet
        Set wsNuovo = ThisWorkbook.Sheets.Add(After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count))
        
        wsOriginale.Cells.Copy
        wsNuovo.Cells.PasteSpecial Paste:=xlPasteAll
        
        Application.CutCopyMode = False
        
        wsNuovo.Name = nomeFoglioNuovo
        Range("A1").Select
    End If
    
    Set wsOriginale = Nothing
    Set wsNuovo = Nothing
    Set ws = Nothing
End Sub

In pratica questa macro ti chiede tramite InputBox il nome del nuovo Foglio che verrà creato, controlla se esiste già un foglio con lo stesso nome, se non esiste...copia il contenuto del Foglio "SAL N°", crea un foglio nuovo, incolla il contenuto copiato, rinomina il nuovo foglio con ciò che hai scritto nella InputBox.

In questo modo non hai nessuna macro nel nuovo Foglio.

Prova e fammi sapere se ti va bene.

Ovviamente se ci sono richieste che vanno oltre la richiesta iniziale...esse devono essere valutate in una nuova discussione. Se questa invece soddisfa le tue esigenze, segnala pure come RISOLTA.

[DodiPartecipante Dodi Karma: 2 pts]

Grazie mille funzione tutto. 

comunque posto il mio codice, 

forse rudimentale 

ma mi funziona bene, lo condivido se può essere di spunto. 

Sub NUOVOSAL()
Dim ws As Worksheet
Dim n As String
Dim ctl As Shape
Dim cell As Range

    If MsgBox("VUOI CREARE UN NUOVO SAL?", vbYesNo + vbQuestion, "NUOVO SAL") = vbNo Then Exit Sub
    
    Do
        n = Application.InputBox(Prompt:="SCRIVI IL NUMERO DEL NUOVO SAL: ", Title:="Nuovo SAL", Type:=1)
        If Trim(n) = "" Then Exit Sub
    Loop Until n > 0
    
    Application.ScreenUpdating = False

    For Each ws In ThisWorkbook.Worksheets
        If ws.Name = "SAL N°" & n Then
            MsgBox "IL NOME DEL FOGLIO ESISTE." & vbCrLf & "IL SAL NON VERRA' CREATO.", vbExclamation, "ALLERT Foglio Esistente"   '(Tipi di avvisi in msgbox) vbCritical -- vbQuestion -- vbInformation --
            Set ws = Nothing
            Exit Sub
        End If
    Next

    Foglio7.Copy After:=Worksheets(Worksheets.Count)    'copia il SAL base in un nuovo SAL
    ActiveSheet.Name = "SAL N°" & n
    
 '-------------------------------------------------------------------------------------------
 ' Alla copia del foglio, cancella il tasto con la scritta ***** (in questo caso NUOVO SAL)
 '-------------------------------------------------------------------------------------------
   
   On Error Resume Next
    For Each ctl In ActiveSheet.Shapes
        If ctl.TextFrame.Characters.Text = "NUOVO SAL" Then ctl.Delete
    Next
    On Error GoTo 0
   
    Range("S2") = n 'copia il numero del testo scritto mella msgbox in un cella
    
   
    ricopia_UMePU
    
    Application.ScreenUpdating = True

End Sub

[DodiPartecipante Dodi Karma: 2 pts]

questo codice 

in parte e mio e in parte è stato rimaneggiato dal grande Vecchiofrac

 

[alexps81Moderatore alexps81 Karma: 58 pts]

Dodi ha scritto:

grande Vecchiofrac

Grandissimo V.F.   

[LukeRedsPartecipante LukeReds Karma: 19 pts]

ciao,

ho allegato una risposta ma non la vedo... la riallego, casomai chiedo ad un moderatore di cancellarne una, grazie

Il foglio "SAL N°" va tenuto per copiare le righe di intestazione sui vari fogli SAL

Sub CreaFogliSal()
Dim sh As Worksheet, rt As Integer, i As Integer, rng As Range, cella As Range, arrList As Object

Application.DisplayAlerts = False
For Each sh In ThisWorkbook.Worksheets
   If Left(sh.Name, 6) = "SAL N°" And Len(sh.Name) > 7 Then sh.Delete
Next sh

Application.DisplayAlerts = True: Application.ScreenUpdating = False
Set sh = Sheets("Progressivo")
rt = sh.Range("A" & Rows.Count).End(xlUp).Row
Set rng = sh.Range("E12:E" & rt)
Set arrList = CreateObject("System.Collections.ArrayList")

For Each cella In rng
   If Not arrList.Contains(cella.Value) Then arrList.Add cella.Value
Next cella

For i = 0 To arrList.Count - 1
   Sheets.Add after:=ActiveSheet
   nome = "SAL N° " & arrList(i)
   ActiveSheet.Name = nome
   Sheets("SAL N°").Range("A1:S6").Copy Destination:=Sheets(nome).Range("A1")
   sh.Range("A8:S" & rt).AutoFilter Field:=5, Criteria1:=arrList(i)
   sh.Range("A9:S" & rt).Copy Destination:=Sheets(nome).Range("A7")
   Sheets(nome).Range("R7:R600").Cut
   Sheets(nome).Range("Q7:Q500").Insert Shift:=xlToRight
   Sheets(nome).Range("S2") = arrList(i)
Next i

sh.Range("A8:S" & rt).AutoFilter Field:=5
Application.ScreenUpdating = True
End Sub

 

 

[Autore]

Articoli