Codici Dupplicati i piu fogli

Hai un problema con Excel?

Nuova discussione

Codici Dupplicati i piu fogli
di Nicola (utente non iscritto) data: 01/08/2017 15:56:06
Buongiorno a tutti.

Avrei bisogno di un VS grande aiuto.

In un file in Excel ho tanti fogli di lavoro che utilizzo per compilare dei codici di prodotto.

Cod Singolo Descrizione
101010 Pippo
202020 Pluto
Vorrei che ogni volta inserito il codice in un foglio , ci sia una macro che mi dica se quel codice è gia presente nel foglio precedente e in quello successivo....

Allego file di esempio per farvi capire meglio il mio problema.

Spero in un vs sostegno...Grazie mille

Famiglia Gruppo Cod M Cod singolo Cod Mix Vol? Descrizione
101010 si Pippo
202020 si Pluto
di alfrimpa data: 01/08/2017 16:48:32
Ma hai allegato un file con il progetto VBA protetto?

Alfredo
Codici Dupplicati i piu fogli
di Nicola (utente non iscritto) data: 01/08/2017 16:57:36
Scusa Alfredo ...

Ho inserito un nuovo file di esempio formattato:
di Vecchio Frac data: 01/08/2017 22:00:26
cit. " un file con il progetto VBA protetto"
---> Alfri non dirmi che questa inezia ti può fermare ^_^
di alfrimpa data: 01/08/2017 22:13:14
Francesco forse non ci crederai ma non ho mai provato a sproteggere un file di Excel perchè la cosa non mi ha mai interessato.

Piuttosto anche dal secondo file allegato non ho capito la richiesta.

Stando su un foglio e si digita un codice si vuole che nella cella a fianco venga indicato se sia presente negli altri due fogli?

Alfredo
di Vecchio Frac data: 01/08/2017 22:50:46
cit. Alfri "non ho mai provato a sproteggere un file di Excel "
---> Mah, possono esserci situazioni od occasioni in cui saper perlomeno farlo diventa importante.

Nel merito, la richiesta originale dice "ogni volta inserito il codice in un foglio , ci sia una macro che mi dica se quel codice è gia presente nel foglio precedente e in quello successivo"; quindi credo di sì, che sia come dici tu (se poi l'esito vada messo in una cella a fianco o visualizzata in un messaggio, è un dettaglio non specificato).
di nicola (utente non iscritto) data: 02/08/2017 08:37:07
cit.di Vecchio Frac
Nel merito, la richiesta originale dice "ogni volta inserito il codice in un foglio , ci sia una macro che mi dica se quel codice è gia presente nel foglio precedente e in quello successivo"; quindi credo di sì, che sia come dici tu (se poi l'esito vada messo in una cella a fianco o visualizzata in un messaggio, è un dettaglio non specificato).

La mia richiesta è esattamente quella citata da Vecchio Frac.

Nel caso trovassi dei codi uguali sia nel foglio precedente e sia in quello successivo al foglio attivo
In una riga vorrei che me lo segnalasse.Vedi esempio nei 3 fogli.

Scusatemi se non sono stato abbastanza chiaro

di Vecchio Frac data: 02/08/2017 10:31:37
Una cosa così, da inserire nel codice del foglio2.

Option Explicit

Private Sub Worksheet_Change(ByVal Target As Range)
Dim c As Range, s As String
Dim sh As Variant

    If Intersect(Target, Range("A:A")) Is Nothing Then Exit Sub
    If Target.Cells.Count > 1 Then Set Target = Target.Resize(1, 1)
    If Trim(Target) = "" Then Exit Sub
    
    Application.EnableEvents = False
        s = ""
        'cerca nel foglio 1 e nel foglio 3 il dato digitato in A
        For Each sh In Array(Sheets("1"), Sheets("3"))
            Set c = sh.Range("A:A").Find(Target, LookAt:=xlWhole)
            If Not (c Is Nothing) Then
                If s = "" Then
                    s = "Articolo usato nel foglio " & sh.Name
                    Target.Offset(, 1) = s
                    Target.Offset(, 2) = c.Offset(, 2)
                Else
                    s = s & "-" & sh.Name
                    Target.Offset(, 1) = s
                    Target.Offset(, 2) = c.Offset(, 2)
                End If
            End If
        Next
        
    Application.EnableEvents = True
End Sub

di nicola (utente non iscritto) data: 02/08/2017 11:59:53
Grande Vecchio Frac ...Funziona benissimo.

Ma ho un po di dubbi e di domande che ti elenco sotto.

1. Nel caso in cui nel file ci fossero piu fogli Esempio 30....Dovrei inserire in ciascuno di essi il tuo codice, modificando il nome del foglio precedente e quello successivo al foglio attivo.
Supponiamo che il foglio venga rinominato Quindi da 1 lo chiamo Pippo, oppure il foglio venga spostato , in questo caso dovresti sempre rimettere le mani nella macro modificando i vari paramentri.

C e una soluzione affinche il codice riconosca il foglio precedente e quello successivo a prescindere dai nomi "For Each sh In Array(Sheets("1"), Sheets("3"))".

2.Nel mio file originale in ciascun foglio ho già un evento "Private Sub Worksheet_Change(ByVal Target As Range)"
Vedi sotto...

Cosa mi consigli di fare in questo caso????

Spero di essere stato chiaro nella mia spigazione

Grazie mille

Sub Worksheet_Change(ByVal Target As Excel.Range)
   
   Dim strCellaModificata As String
   Dim strColonna As String
   Dim strRiga As String
   Dim intrisposta As Integer
   Dim y As Long, Rng As Range, firstAddress As String
   Dim blnTrovato As Boolean
   Dim strWorkbook As String
   Dim Riga As Long, LastRow As Long, Col As Long, ColS As String
   Dim ID As String, Sh1 As Worksheet, RangeMaster As Range, RangeSingolo As Range
   Set RangeMaster = Range("C9:C" & Cells(Rows.Count, "C").End(xlUp).Row)
   Set RangeSingolo = Range("D9:D" & Cells(Rows.Count, "D").End(xlUp).Row)
   
    If Target.Count > 1 Then Exit Sub
    If Not Intersect(Target, RangeMaster) Is Nothing Or Not Intersect(Target, RangeSingolo) Is Nothing Then
       Col = Target.Column
       If Col = 3 Then ColS = "B": If Col = 4 Then ColS = "A"
    Const conPercorso = "\CLUSTERFSSharePiano MarketingDb_MasterDb_Generale_db_new" 'new
   
   strWorkbook = ActiveWorkbook.Name

   Application.ScreenUpdating = False
   Application.EnableEvents = False
   
   Workbooks.Open Filename:=conPercorso & "dbnew.xlsm", ReadOnly:=True
   LastRow = Workbooks("dbnew.xlsm").Worksheets("db").Cells(Rows.Count, Col).End(xlUp).Row

    Riga = Cells(Rows.Count, "D").End(xlUp).Row + 1
    If Riga < 9 Then Riga = 9
    Workbooks(strWorkbook).Activate
    Set Sh1 = Workbooks(strWorkbook).ActiveSheet

 ID = Target.Value
 With Workbooks("dbnew.xlsm").Worksheets("db").Range(ColS & "2:" & ColS & LastRow)
  Set Rng = .Find(What:=ID, LookAt:=xlWhole, LookIn:=xlValues)
  If Not Rng Is Nothing Then
     blnTrovato = True
    If ColS = "B" Then
    firstAddress = Rng.Address
    Do
     Sh1.Range("D" & Riga).Value = Rng.Offset(0, -1)
     Sh1.Range("E" & Riga).Value = Rng.Offset(0, 0)
     Sh1.Range("J" & Riga).Value = Rng.Offset(0, 1)
     Sh1.Range("H" & Riga).Value = Rng.Offset(0, 4)
     Sh1.Range("I" & Riga).Value = Rng.Offset(0, 5)
     Sh1.Range("G" & Riga).Value = Rng.Offset(0, 3)
     Sh1.Range("K" & Riga).Value = Rng.Offset(0, 6)
     Sh1.Range("P" & Riga).Value = Rng.Offset(0, 8)
     Sh1.Range("V" & Riga).Value = Rng.Offset(0, 7)
     Sh1.Range("Y" & Riga).Value = Rng.Offset(0, 13)
     Sh1.Range("AA" & Riga).Value = Rng.Offset(0, 14)
     Sh1.Range("AB" & Riga).Value = Rng.Offset(0, 19)
     Sh1.Range("AC" & Riga).Value = Rng.Offset(0, 20)
     Sh1.Range("A" & Riga).Value = Rng.Offset(0, 18)
     Sh1.Range("B" & Riga).Value = Rng.Offset(0, 16)
     Sh1.Range("AE" & Riga).Value = Rng.Offset(0, 23)
     Sh1.Range("AI" & Riga).Value = Rng.Offset(0, 25)
     Sh1.Range("AJ" & Riga).FormulaR1C1 = "=IF(ISERROR(RC[-7]*RC[-24]),0,(RC[-7]*RC[-24]))"
     Sh1.Range("AK" & Riga).FormulaR1C1 = "=IF(ISERROR(RC[-8]*RC[-20]/1.22),0,(RC[-8]*RC[-20]/1.22))"
     Riga = Riga + 1
      Set Rng = .FindNext(Rng)
     
    Loop While Not Rng Is Nothing And Rng.Address <> firstAddress
    
    Else
      Sh1.Range("E" & Riga - 1).Value = Rng.Offset(0, 0)
      Sh1.Range("J" & Riga - 1).Value = Rng.Offset(0, 2)
      Sh1.Range("H" & Riga - 1).Value = Rng.Offset(0, 5)
      Sh1.Range("I" & Riga - 1).Value = Rng.Offset(0, 6)
      Sh1.Range("G" & Riga - 1).Value = Rng.Offset(0, 4)
      Sh1.Range("K" & Riga - 1).Value = Rng.Offset(0, 7)
      Sh1.Range("P" & Riga - 1).Value = Rng.Offset(0, 9)
      Sh1.Range("V" & Riga - 1).Value = Rng.Offset(0, 8)
      Sh1.Range("Y" & Riga - 1).Value = Rng.Offset(0, 14)
      Sh1.Range("AA" & Riga - 1).Value = Rng.Offset(0, 15)
      Sh1.Range("AB" & Riga - 1).Value = Rng.Offset(0, 20)
      Sh1.Range("AC" & Riga - 1).Value = Rng.Offset(0, 21)
      Sh1.Range("A" & Riga - 1).Value = Rng.Offset(0, 19)
      Sh1.Range("B" & Riga - 1).Value = Rng.Offset(0, 17)
      Sh1.Range("AE" & Riga - 1).Value = Rng.Offset(0, 24)
      Sh1.Range("AI" & Riga - 1).Value = Rng.Offset(0, 26)
      Sh1.Range("AJ" & Riga - 1).FormulaR1C1 = "=IF(ISERROR(RC[-7]*RC[-24]),0,(RC[-7]*RC[-24]))"
      Sh1.Range("AK" & Riga - 1).FormulaR1C1 = "=IF(ISERROR(RC[-8]*RC[-20]/1.22),0,(RC[-8]*RC[-20]/1.22))"
  End If
 End If
End With
Application.DisplayAlerts = False
Workbooks("dbnew.xlsm").Close
Application.DisplayAlerts = True
  If blnTrovato = False Then
  
  intrisposta = MsgBox("Il prodotto inserito non è presente nell'archivio, " _
   & "vuoi aprire il file dbnew per aggiungerlo?", vbYesNo)
   
   If intrisposta = vbYes Then
     frmPassword.Show
    End If
   End If
 End If
 Application.ScreenUpdating = True
 Application.EnableEvents = True
 Set Sh1 = Nothing
 Set Rng = Nothing
 Set RangeMaster = Nothing
 Set RangeSingolo = Nothing
End sub

di Vecchio Frac data: 02/08/2017 13:26:51
Le domande sono molto pertinenti e implicano un ripensamento anche della struttura del file di lavoro.

1) Se i fogli sono sempre numerati sequenzialmente il problema può non porsi perchè puoi impostare un riferimento al foglio precedente e successivo a quello attivo semplicemente modificandone l'indice nel nome:
```
sh1 = ActiveSheet.Name -1: sh2 = ActiveSheet.Name + 1

For Each sh In Array(Sheets(ActiveSheet.Name - 1), Sheets(ActiveSheet.Name + 1))
```
prestando naturalmente molta attenzione a gestire bene i due casi estremi in cui sia selezionato il foglio 1 (prima di questo non ci sono fogli) o l'ultimo (dopo il quale parimenti non ci sono fogli).
Non si pone problema neanche se l'utente rinomina i fogli in altro modo perchè ogni oggetto Worksheet espone i metodi "Next" e "Previous" per riferirsi ai fogli rispettivamente successivi e precedente:
```
For Each sh In Array(ActiveSheet.Previous, ActiveSheet.Next))
```
.

2) Poichè esiste già una routine che intercetta l'evento Change per ogni foglio, puoi considerare di spostare tale routine a livello di ThisWorkbook (evento Workbook_SheetChange), con il vantaggoi di scriverne solo una e di poter fare facilmente modifiche che interessano contemporaneamente tutit i fogli. ~~Attenzione che nel codice che hai mostrato mancano le fondamentali istruzioni che abilitano e disabilitano gli eventi. Importante particolarmente quando si intercettano gli eventi *_Change.~~
Ora, sarebbe da spiegare nel dettaglio cosa fa questa routine (non ho molta voglia di tradurmela ^_^) ma puoi integrarla perfettamente col nuovo codice che ti serve.

edit by VF: ho scritto una sciocchezza e la cancello. Ho letto meglio il tuo codice ^_^ e le istruzioni ci sono, io le avrei disposte diversamente ma è solo questione di stile, non di tecnica.
di nicola (utente non iscritto) data: 03/08/2017 10:55:34
Ciao VF ...sto provando da ieri il codice con questa modifica For Each sh In Array(ActiveSheet.Previous, ActiveSheet.Next))

Inserito in ciascun foglio funziona ma se inserisco l'inserisco l'intero codice nella cartella "Questa cartella di lavoro" mi da errore e non funziona.

Non capisco dove sbagli
di nicola (utente non iscritto) data: 03/08/2017 10:57:43
Ho allegato il file con la macro nella cartella di lavoro

grazie

di Vecchio Frac data: 03/08/2017 11:19:19
Il Workbook è un oggetto composto da molti fogli e l'oggetto ActiveSheet per lui purtroppo non ha senso. Se guardi da vicino la firma della routine (cioè la sua declaratoria) che intercetta un evento _Change in un foglio vedi questa cosa:

Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Source As Range)

cioè alla routine viene passato in argomento un oggetto "Sh" e un oggetto "Source", dove Sh è il foglio modificato, il Source è la cella (o un range di celle) che hanno subito la modifica.
La routine che era valida a livello di foglio, ora va modificata perchè adesso è generica e si può riferire a qualsiasi foglio: il programmatore deve dire al Workbook esattamente a cosa deve riferirsi e qualificare correttamente i range di riferimento (per esempio Target non esiste più, ora si chiama Source).
Credo però che dovresti determinare qual è il foglio del quale non va intercettata la modifica altrimenti è un cane che si morde la coda ^_^
Comunque guarda il codice corretto e confrontalo con quello foglio per foglio e vedrai che le differenze (e i cambiamenti) ti salteranno agli occhi.

Option Explicit

Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Source As Range)
Dim c As Range, s As String, ws As Variant
Dim wsheets As Variant
    If Intersect(Source, Sh.Range("A:A")) Is Nothing Then Exit Sub
    If Source.Cells.Count > 1 Then Set Source = Source.Resize(1, 1)
    If Trim(Source) = "" Then Exit Sub
    
    Application.EnableEvents = False
        s = ""
        'cerca nel foglio precedente e nel foglio successivo il dato digitato in A
        If Sh.Index = 1 Then
            wsheets = Array(Sh.Next)
        ElseIf Sh.Index = ThisWorkbook.Sheets.Count Then
                wsheets = Array(Sh.Previous)
            Else
                wsheets = Array(Sh.Previous, Sh.Next)
        End If
        
        For Each ws In wsheets
            Set c = ws.Range("A:A").Find(Source, LookAt:=xlWhole)
            If Not (c Is Nothing) Then
                If s = "" Then
                    s = "Articolo usato nei fogli: " & ws.Name
                    Source.Offset(, 1) = s
                    Source.Offset(, 2) = c.Offset(, 2)
                Else
                    s = s & "-" & ws.Name
                    Source.Offset(, 1) = s
                    Source.Offset(, 2) = c.Offset(, 2)
                End If
            End If
        Next
        
    Application.EnableEvents = True
End Sub

di nicola (utente non iscritto) data: 03/08/2017 11:22:13
Grazie VF mi controllo subito la tua spigazione ....grande come sempre

di nicola (utente non iscritto) data: 03/08/2017 15:59:54
Funziona benissimo-----Sei un genio...

Ho un ultimo quesito che sto provando a capire.

Set c = ws.Range("A:B").Find(Source, LookAt:=xlWhole)

Vorrei avere 2 opzioni di inserimento prodotto.

Sia nel Range A e sia Nel Rage B.

Vedi il tuo codice modificato da me

Sarebbe possibile ...Se si sarebbe bellissimo

Option Explicit

Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Source As Range)
Dim c As Range, s As String, ws As Variant
Dim wsheets As Variant
    If Intersect(Source, Sh.Range("A:B")) Is Nothing Then Exit Sub
    If Source.Cells.Count > 1 Then Set Source = Source.Resize(1, 1)
    If Trim(Source) = "" Then Exit Sub
    
    Application.EnableEvents = False
        s = ""
        'cerca nel foglio precedente e nel foglio successivo il dato digitato in A
        If Sh.Index = 1 Then
            wsheets = Array(Sh.Next)
        ElseIf Sh.Index = ThisWorkbook.Sheets.Count Then
                wsheets = Array(Sh.Previous)
            Else
                wsheets = Array(Sh.Previous, Sh.Next)
        End If
        
        For Each ws In wsheets
            Set c = ws.Range("A:B").Find(Source, LookAt:=xlWhole)
            If Not (c Is Nothing) Then
                If s = "" Then
                    s = "Articolo usato nei fogli: " & ws.Name
                    Source.Offset(, 2) = s
                    Source.Offset(, 2) = c.Offset(, 2)
                Else
                    s = s & "-" & ws.Name
                    Source.Offset(, 2) = s
                    Source.Offset(, 2) = c.Offset(, 2)
                End If
            End If
        Next
        
    Application.EnableEvents = True
End Sub

di nicola (utente non iscritto) data: 03/08/2017 17:04:04
Aiuto

sto cercando di capire il tuo codice ...Ma per me è molto difficile...

Se hai un po di tempo ti pregherei di spigarlmelo come si fa con i bambini piccoli

Sto provando da ore ma non ne cavo piede
di Vecchio Frac data: 03/08/2017 21:45:49
Guarda scusami ma sono appena tornato... domani ti spiego il codice per benino, e cercherò anche di capire cosa intendi per "avere due opzioni di inserimento prodotto". E comunque sì il concetto è quello che hai provato a bozzare ^_^ non ti funziona? perchè?
di nicola (utente non iscritto) data: 04/08/2017 09:10:21
Tranquillo VF ...anzi grazie che sei sempre disponibile e un grande maestro.

Cerco di spigare meglio cosa intendo "avere due opzioni di inserimento prodotto".

Inserisco un esempio con la spigazione di come lavoro nel mio progetto originale che utilla in codice sotto elencato.

Spero di essermi spigato in quanto non è facile trovare le parole e i concetti giusti..

Perdonami

di nicola (utente non iscritto) data: 04/08/2017 09:13:08
Ecco il codice

Sub Worksheet_Change(ByVal Target As Excel.Range)
   
   Dim strCellaModificata As String
   Dim strColonna As String
   Dim strRiga As String
   Dim intrisposta As Integer
   Dim y As Long, Rng As Range, firstAddress As String
   Dim blnTrovato As Boolean
   Dim strWorkbook As String
   Dim Riga As Long, LastRow As Long, Col As Long, ColS As String
   Dim ID As String, Sh1 As Worksheet, RangeMaster As Range, RangeSingolo As Range
   Set RangeMaster = Range("C9:C" & Cells(Rows.Count, "C").End(xlUp).Row)
   Set RangeSingolo = Range("D9:D" & Cells(Rows.Count, "D").End(xlUp).Row)
   
    If Target.Count > 1 Then Exit Sub
    If Not Intersect(Target, RangeMaster) Is Nothing Or Not Intersect(Target, RangeSingolo) Is Nothing Then
       Col = Target.Column
       If Col = 3 Then ColS = "B": If Col = 4 Then ColS = "A"
    Const conPercorso = "\CLUSTERFSSharePiano MarketingDb_MasterDb_Generale_db_new" 'new
   
   strWorkbook = ActiveWorkbook.Name

   Application.ScreenUpdating = False
   Application.EnableEvents = False
   
   Workbooks.Open Filename:=conPercorso & "dbnew.xlsm", ReadOnly:=True
   LastRow = Workbooks("dbnew.xlsm").Worksheets("db").Cells(Rows.Count, Col).End(xlUp).Row

    Riga = Cells(Rows.Count, "D").End(xlUp).Row + 1
    If Riga < 9 Then Riga = 9
    Workbooks(strWorkbook).Activate
    Set Sh1 = Workbooks(strWorkbook).ActiveSheet

 ID = Target.Value
 With Workbooks("dbnew.xlsm").Worksheets("db").Range(ColS & "2:" & ColS & LastRow)
  Set Rng = .Find(What:=ID, LookAt:=xlWhole, LookIn:=xlValues)
  If Not Rng Is Nothing Then
     blnTrovato = True
    If ColS = "B" Then
    firstAddress = Rng.Address
    Do
     Sh1.Range("D" & Riga).Value = Rng.Offset(0, -1)
     Sh1.Range("E" & Riga).Value = Rng.Offset(0, 0)
     Sh1.Range("J" & Riga).Value = Rng.Offset(0, 1)
     Sh1.Range("H" & Riga).Value = Rng.Offset(0, 4)
     Sh1.Range("I" & Riga).Value = Rng.Offset(0, 5)
     Sh1.Range("G" & Riga).Value = Rng.Offset(0, 3)
     Sh1.Range("K" & Riga).Value = Rng.Offset(0, 6)
     Sh1.Range("P" & Riga).Value = Rng.Offset(0, 8)
     Sh1.Range("V" & Riga).Value = Rng.Offset(0, 7)
     Sh1.Range("Y" & Riga).Value = Rng.Offset(0, 13)
     Sh1.Range("AA" & Riga).Value = Rng.Offset(0, 14)
     Sh1.Range("AB" & Riga).Value = Rng.Offset(0, 19)
     Sh1.Range("AC" & Riga).Value = Rng.Offset(0, 20)
     Sh1.Range("A" & Riga).Value = Rng.Offset(0, 18)
     Sh1.Range("B" & Riga).Value = Rng.Offset(0, 16)
     Sh1.Range("AE" & Riga).Value = Rng.Offset(0, 23)
     Sh1.Range("AI" & Riga).Value = Rng.Offset(0, 25)
     Sh1.Range("AJ" & Riga).FormulaR1C1 = "=IF(ISERROR(RC[-7]*RC[-24]),0,(RC[-7]*RC[-24]))"
     Sh1.Range("AK" & Riga).FormulaR1C1 = "=IF(ISERROR(RC[-8]*RC[-20]/1.22),0,(RC[-8]*RC[-20]/1.22))"
     Riga = Riga + 1
      Set Rng = .FindNext(Rng)
     
    Loop While Not Rng Is Nothing And Rng.Address <> firstAddress
    
    Else
      Sh1.Range("E" & Riga - 1).Value = Rng.Offset(0, 0)
      Sh1.Range("J" & Riga - 1).Value = Rng.Offset(0, 2)
      Sh1.Range("H" & Riga - 1).Value = Rng.Offset(0, 5)
      Sh1.Range("I" & Riga - 1).Value = Rng.Offset(0, 6)
      Sh1.Range("G" & Riga - 1).Value = Rng.Offset(0, 4)
      Sh1.Range("K" & Riga - 1).Value = Rng.Offset(0, 7)
      Sh1.Range("P" & Riga - 1).Value = Rng.Offset(0, 9)
      Sh1.Range("V" & Riga - 1).Value = Rng.Offset(0, 8)
      Sh1.Range("Y" & Riga - 1).Value = Rng.Offset(0, 14)
      Sh1.Range("AA" & Riga - 1).Value = Rng.Offset(0, 15)
      Sh1.Range("AB" & Riga - 1).Value = Rng.Offset(0, 20)
      Sh1.Range("AC" & Riga - 1).Value = Rng.Offset(0, 21)
      Sh1.Range("A" & Riga - 1).Value = Rng.Offset(0, 19)
      Sh1.Range("B" & Riga - 1).Value = Rng.Offset(0, 17)
      Sh1.Range("AE" & Riga - 1).Value = Rng.Offset(0, 24)
      Sh1.Range("AI" & Riga - 1).Value = Rng.Offset(0, 26)
      Sh1.Range("AJ" & Riga - 1).FormulaR1C1 = "=IF(ISERROR(RC[-7]*RC[-24]),0,(RC[-7]*RC[-24]))"
      Sh1.Range("AK" & Riga - 1).FormulaR1C1 = "=IF(ISERROR(RC[-8]*RC[-20]/1.22),0,(RC[-8]*RC[-20]/1.22))"
  End If
 End If
End With
Application.DisplayAlerts = False
Workbooks("dbnew.xlsm").Close
Application.DisplayAlerts = True
  If blnTrovato = False Then
  
  intrisposta = MsgBox("Il prodotto inserito non è presente nell'archivio, " _
   & "vuoi aprire il file dbnew per aggiungerlo?", vbYesNo)
   
   If intrisposta = vbYes Then
     frmPassword.Show
    End If
   End If
 End If
 Application.ScreenUpdating = True
 Application.EnableEvents = True
 Set Sh1 = Nothing
 Set Rng = Nothing
 Set RangeMaster = Nothing
 Set RangeSingolo = Nothing
End sub

di Vecchio Frac data: 04/08/2017 09:42:51
Io ho preparato un commento al codice che avevo scritto io, modificato per permettere di considerare la modifica delle colonne A e B.
Per comodità allego il mio file ("Volantino_2017_VF.xlsm") così capisci meglio.

Non so se ti basta o se vuoi che metto mano al tuo, il che comporta però un certo lavoro e una certa fatica anche per ricostruire lo scenario (sempre se non alleghi il file originale su cui lavorare).

Option Explicit

' digito un codice in colonna A o B di qualunque foglio
' l'evento viene intercettato e se il codice digitato viene
' rinvenuto nel foglio precedente o in quello successivo
' allora vengono riportati i dati del codice trovato
' (compreso il nome del foglio in cui si trovano)


Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Source As Range)
' dichiaro le variabili necessarie
' l'evento fornisce già un riferimento al foglio e al range modificato
Dim c As Range, s As String, ws As Variant
Dim wsheets As Variant      'array che contiene il foglio prima e quello dopo

    'alcuni controlli per evitare errori di compilazione.
    'posso digitare solo in colonna A e in colonna B:
    If Intersect(Source, Sh.Range("A:B")) Is Nothing Then Exit Sub
    
    'viene ignorata la modifica delle prime due righe di ogni foglio:
    If Source.Row <= 2 Then Exit Sub
    
    'un range multicelle viene ridotto a una cella sola:
    If Source.Cells.Count > 1 Then Set Source = Source.Resize(1, 1)
    
    'se premo Canc elimina i dati della riga (celle A:D), ma chiede conferma:
    If Trim(Source) = "" Then
        If MsgBox("Eliminare?", vbYesNo + vbQuestion) = vbNo Then Application.Undo: Exit Sub
        Application.EnableEvents = False        'importante per evitare ricorsione
            Range(Sh.Cells(Source.Row, "A"), Sh.Cells(Source.Row, "D")).ClearContents
        Application.EnableEvents = True
        Exit Sub
    End If
    
    'disabilita gli eventi. E' importante disabilitare gli eventi
    'in routine che intercettano gli eventi altrimenti si genera ricorsione
    'gli eventi vengono riabilitati prima di uscire dalla routine
    Application.EnableEvents = False
        
    s = ""
    
    'adesso si occupa di cercare il codice digitato bel foglio precedente e
    'in quello successivo a quello che si sta modificando
    
    'se il foglio modificato è il primo devi cercare solo nel successivo...
    If Sh.Index = 1 Then
        wsheets = Array(Sh.Next)
    ElseIf Sh.Index = ThisWorkbook.Sheets.Count Then
        'altrimenti se il foglio è l'ultimo devi cecare solo nel precedente...
            wsheets = Array(Sh.Previous)
        Else
            'altrimenti devi cercare sia nel precedente che nel successivo
            wsheets = Array(Sh.Previous, Sh.Next)
        End If
    
    'esamina ogni foglio nell'array di fogli da considerare
    For Each ws In wsheets
        
        'imposta un riferimento alle colonne A e B del foglio in scansione
        'e cerca in esse il valore digitato (Source)
        'se non lo trova prosegue senza fare niente
        Set c = ws.Range("A:B").Find(Source, LookAt:=xlWhole)
        
        If Not (c Is Nothing) Then
            'trovato! predispone la scritta per la colonna "Locazione"
            'in cui inserisce il nome dei(l) fogli(o) in cui si trova il dato cercato
            If s = "" Then
                s = "Articolo usato nei fogli: " & ws.Name
            Else
                s = s & "-" & ws.Name
            End If
            
            'completa l'inserimento dei dati
            'se avevo digitato il codice in colonna A recupera il dato in colonna B
            'e viceversa
            If c.Column = 1 Then
                Sh.Cells(Source.Row, "B") = ws.Cells(c.Row, "B")
            Else
                Sh.Cells(Source.Row, "A") = ws.Cells(c.Row, "A")
            End If
            
            'inserisce in colonna C ("Locazione") i dati recuperati dal foglio sorgente
            Sh.Cells(Source.Row, "C") = s
            Sh.Cells(Source.Row, "D") = ws.Cells(c.Row, "D")
        End If
    
    'prossimo foglio.
    Next
        
    'riabilita gli eventi
    Application.EnableEvents = True
End Sub

di Vecchio Frac data: 04/08/2017 09:44:52
p.s.
Adesso ho visto il tuo file di spiegazione.
Ci do un occhio :)
di nicola (utente non iscritto) data: 04/08/2017 09:50:49
Sto studiando filo e per segno la tua spiegazione ....sei un mito
di Vecchio Frac data: 04/08/2017 09:55:30
Ho letto la spiegazione... è più incasinata la spiegazione del file ^_^ (a.i.v.)

cit. "Pensavo questa notte se è possibile utilizzare un metodo diverso da l'evento change"
---> Dormi la notte no? così dopo sei più fresco ^_^
Scherzi a parte: no, l'evento da intercettare è sempre _Change, ma si può pilotarlo in modo da fargli fare solo quello che vogliamo.
Comunque non è chiara una cosa, per restare nell'esempio che hai fornito:
Tu dici: "Nella colonna C inserisco il codice 027002 e attraverso l'evento change viene popolata la colonna d con 3 codici singoli "027004";"027002";"027003" in quanto questi articoli hanno in comune il codice inserito nella colonna c "027002"). "
Ma come fai a stabilire quali celle della colonna D vengono popolate con i codici 027*? e con che criterio assegni i numeri diversi alle singole celle? ossia, da dove viene il codice singolo, in funzione del codice Master? Il discriminante è forse la colonna "Cod Mix"?

Tu dici prima "Nella colonna C inserisco il codice" e poi "Nella colonna D invece inserisco il codice singolo", ma alla fine dici "In modo da far verificare al codice sempre una sola colonna, in questo caso la colonna D"; allora le colonne da controllare sono una o due? Scegli ^_^

In sostanza però invece di pensare a cosa far fare a Excel, devi aver chiaro cosa fai tu manualmente per avere un risultato.
In pratica, se non avessi codice nè formule, come faresti, a mano, a compiere queste operazioni di inserimento, verifica e ricerca? descrivi questi passaggi e poi li traduciamo in codice funzionante. (non ho ancora guardato il tuo codice che magari funziona e ha bisogno solo di una limata).
di nicola (utente non iscritto) data: 04/08/2017 10:48:08
Ti invio progetto originale chiamato "Volantino Saponi&Profumi_Nico 2017 - Copia.xlsm" con file che utilizzo per popolare il "Volantino saponi&Profumi" chiamato dbnew con password "nicola".

Se cambi un attimo il percorso della cartella e digiti un codice presente nel dbnew capisci con chiarezza quello che non riesco a spiegarti(((devo dormire di piu)))

Nel dbnew ci sono nella colonna ha i codici singoli e nella colonna b i codici master.

se la colonna b e vuota significa che esite solo il codice singolo.

Aprendo il file volantino saponi&profumi i codici singoli gli digito in d e i codici master in c..

Prova e vedrai cosa accade...
di nicola (utente non iscritto) data: 04/08/2017 11:44:46
Ma sai che malgrado "io" sia pessimo nelle spigazioni...il tuo ultimo codice fuonziona???

Ho provato a disabilitare

If c.Column = 1 Then
Sh.Cells(Source.Row, "B") = ws.Cells(c.Row, "B")
Else
Sh.Cells(Source.Row, "A") = ws.Cells(c.Row, "A")
End If
Sh.Cells(Source.Row, "D") = ws.Cells(c.Row, "D")
in quanto il dato lo prendo sempre dal dbnew.

In questo modo mi pare funzioni alla grande ...

Che ne pensi????
di Vecchio Frac data: 04/08/2017 11:50:38
Non saprei, devo ancora controllare i tuoi ultimi file... ma se ti pare che funzioni (però non va bene "disabilitare" alla cieca, occorre sapersi spiegare il perchè delle cose)... se cancelli le istruzioni che recuperano i dati, allora le devi sostituire con altre che recuperano i dati altrimenti non vedi niente ^_^
di nicola (utente non iscritto) data: 04/08/2017 15:42:10
Ti invio l'ultimo file dove ho inserito il tuo codice ....

Volantino Saponi&Profumi_Nico 2017 - Copia.xlsm

Ho riscontrato un prolema quando vado ad inserire nuove righe "Copio e inserisco celle copiate"...Si abilita

If MsgBox("Eliminare?", vbYesNo + vbQuestion) = vbNo

Inoltre sarebbe meglio impostare il codice per cancellare l'intera riga in quanto ho notato che premendo canc sulla colonna c o d ossia dove c'e la presenza del codice prodotto, il codice inserito nel foglio va in tilt e inserisce prodotti a caso.

Tutto il resto è una figata ...
di Vecchio Frac data: 04/08/2017 20:03:55
Ma guarda che tutto il codice dei singoli fogli lo puoi scrivere una volta sola, nel codice del Workbook_SheetChange, eventualmente spezzettando in sottoroutine più facili da gestire. Altrimenti se fai una modifica al path da una parte la devi replicare su tutti i fogli e questa è una scocciatura :)
Adesso guardo comunque il problema che hai segnalato.
di Vecchio Frac data: 05/08/2017 20:23:20
Non riesco a riprodurre la condizione di errore :(
Comunque il foglio è complesso e avendo anche una base dati separata, ben strutturata, ti consiglio di prendere seriamente in esame la possibilità di trasferire tutto su Access. Qualche problema in più soprattutto all'inizio per l'impostazione ma mille problemi in meno sia per la gestione che per la manutenzione del codice.
di Vecchio Frac data: 05/08/2017 20:38:29
cit. "Ho riscontrato un prolema quando vado ad inserire nuove righe "Copio e inserisco celle copiate"...Si abilita If MsgBox("Eliminare?", vbYesNo + vbQuestion) = vbNo "
---> Ah adesso ho visto e capito, è perchè l'inserimento di una riga nuova comporta che il range "Source" sia una cella vuota e quindi l'If che verifica se l'oggetto Source è vuoto si attiva...
Modifica così:
```
    'un range multicelle viene ridotto a una cella sola:

    If Source.Cells.Count > 1 Then Application.EnableEvents=True: Exit Sub
```
forzando l'uscita dalla sub in caso di impostazione multicelle...
di Vecchio Frac data: 05/08/2017 20:39:23
cit. "Ho riscontrato un prolema quando vado ad inserire nuove righe "Copio e inserisco celle copiate"...Si abilita If MsgBox("Eliminare?", vbYesNo + vbQuestion) = vbNo "
---> Ah adesso ho visto e capito, è perchè l'inserimento di una riga nuova comporta che il range "Source" sia una cella vuota e quindi l'If che verifica se l'oggetto Source è vuoto si attiva...
Modifica così:
```
    'un range multicelle viene ridotto a una cella sola:
    If Source.Cells.Count > 1 Then Exit Sub
```
forzando l'uscita dalla sub in caso di impostazione multicelle...
di nicola (utente non iscritto) data: 07/08/2017 10:57:07
Ciao VF scusa se ti rispondo ora ...ma dal venerdi alla domenica non posso accedere al pc.

Ho provato a fare la modifica
Cit.VF
Modifica così:

'un range multicelle viene ridotto a una cella sola:
If Source.Cells.Count > 1 Then Exit Sub

forzando l'uscita dalla sub in caso di impostazione multicelle...

Funziona benissimo ..

Ho un'altro problema

Errore di Run time 1004
metodo undo dell'oggetto application non riuscito.

Inolotre vorrei che quando faccio canc nel "source" eliminasse l'intera riga.
di Vecchio Frac data: 07/08/2017 11:10:41
cit. "vorrei che quando faccio canc nel "source" eliminasse l'intera riga. "
---> Bisogna intervenire in questa parte del codice:
If Trim(Source) = "" Then
If MsgBox("Eliminare?", vbYesNo + vbQuestion) = vbNo Then Application.Undo: Exit Sub
Application.EnableEvents = False 'importante per evitare ricorsione
Range(Sh.Cells(Source.Row, "A"), Sh.Cells(Source.Row, "D")).ClearContents
Application.EnableEvents = True
Exit Sub
End If

dove la riga evidenziata dovrà diventare:
Source.EntireRow.ClearContents
di Vecchio Frac data: 07/08/2017 11:21:46
Comunque sto provando a mettere mano al codice per armonizzare quello dei singoli fogli in un'unica posizione (in ThisWorkbook). Spero di avere tempo e tranquillità per farlo... oggi è rientrato il capo dalle ferie e non tira buona aria ^_^
di nicola (utente non iscritto) data: 07/08/2017 11:24:54
Poi oggi è anche lunedì

Comunque te ne sarei grato .....sei un fenomeno....
di Nicola (utente non iscritto) data: 07/08/2017 15:15:12
We VF appena hai un minuto...Mi giudichi il file VF che ti ho inviato...

Per cancellare la riga ho inserito nel modulo 1 il metodo sendkeys che alla pressione del tato f6 cancella la riga senza che si attivino eventi derivati dagli eventi change...

...ogni tanto il tasto comunque non lancia la macro...booooo
di Vecchio Frac data: 07/08/2017 15:34:46
cit. "ogni tanto il tasto comunque non lancia la macro"
---> Sì certo è giusto che sia così, il motivo è che ridefinisci un tasto ma Excel non sa che lo hai ridefinito finchè non lanci la macro che lo ridefinisce ("macroprova").
vedrai che, casualmente, funziona regolarmente se lanci "macroprova" e poi premi F6.
Per fare in modo che il tasto venga "attivato" sempre, all'apertura del tuo file, quindi, devi lanciare "macroprova" (o mettere il codice che vi si trova) nell'evento Workbook_Open del tuo file. Se l'evento non c'è lo devi generare (editor di codice, seleziona ThisWorkbook, scegli l'oggetto Workbook a sinistra ed il suo evento Open a destra).
Consiglio poi di creare l'evento Workbook_BeforeClose che ripristina il comportamento normale di F6 con il codice Application.OnKey "{F6}"
di nicola (utente non iscritto) data: 07/08/2017 16:15:31
VF cosa dire ....sei un genio...ti ho inviato il file VF new...

Ora funziona tutto...

Il tasto F6 cancella l'itera riga
Trovo i codici gia usati nel foglio prima e dopo a quello attivo.
Inserisco righe nel progetto senza problemi...

Mi piacerebbe modificare insieme a te il mio codice change e portarlo solo
sulla cartella di lavoro..

Ma ovviamente dipende da te visto che mi hai dedicato un sacco di tempo---

Che faccio spunto come discussione risolta???
di Vecchio Frac data: 07/08/2017 19:47:39
cit. "Mi piacerebbe modificare insieme a te il mio codice change e portarlo solo sulla cartella di lavoro.. "
---> Solo questione di un attimo di tempo... dammi fiducia ^_^
Metterai come risolta quando... sarà risolta :P
di nicola (utente non iscritto) data: 08/08/2017 09:39:01
Grazie VF ...Grazie di cuore
di Vecchio Frac data: 08/08/2017 13:59:26
Allora, ci ho provato.
Dai un'occhiata.
Ho anche tentato di sistemare il codice delle varie form dove mi sembrava utile metterci mano.
Allego il file "New_VF2.xlsm", da testare a dovere. Ci sarà sicuramente qualcosa da sistemare ^^
di nicola (utente non iscritto) data: 08/08/2017 14:27:24
Ma come cavolo faiiiiiiiii....Quanto vorrei un insegnate come te...pagherei oroooooooooo...

Ora testo il tutto nel progetto originale...

MI accorgo sempre di piu che sono meno di zeroooooooooo
di Vecchio Frac data: 08/08/2017 15:21:47
Diciamo che mi piace e ci provo ^_^
Non è che dico o scrivo sempre delle assolute verità, sia chiaro.
Fammi sapere cosa c'è da aggiustare perchè ci sarà sicuramente da aggiustare qualcosa!

(Comunque un po' di oro mi farebbe comodo... ma va bene anche una birra a me o una piccolissima donazione al forum, se proprio sei molto generoso )
di nicola (utente non iscritto) data: 08/08/2017 15:30:34
VF ti conosco ormai da anni ....((Sono un tuo fan))e mi hai sempre dato una mano...quelle piccole cose ((ma per me grandi)) le ho capite seguendo il forum.

Averti vicino casa ti riempirei di birre fidati...((ichnusa birra sarda))

E comunque io ho contributo in passato nelle donazioni e contribuirò nuovamente in quanto questo forum è il numero 1..

Sto testando il codice in tutte le sue parti e adattandolo al progetto originale...
Appena concludo ti faccio sapereeee
di Vecchio Frac data: 08/08/2017 15:44:55
Guarda sulla donazione stavo scherzando... non voglio assolutamente che il messaggio sia: "qui si dà una mano solo in cambio della donazione". Per fortuna non è così grazie al lavoro del nostro patron Mauro che sostiene le spese di gestione e di amministrazione.
Scusami se non posso dire di conoscerti... ho visto talmente tanti utenti che non riesco a ricordare tutte le pratiche affrontate insieme ^_^
L'unica cosa su cui non si può scherzare è la birra (non c'è l'icona della birra, peccato ^_^) e con questo caldo farebbe piacere :)
di nicola (utente non iscritto) data: 09/08/2017 09:15:56
cit VF
L'unica cosa su cui non si può scherzare è la birra (non c'è l'icona della birra, peccato ^_^) e con questo caldo farebbe piacere :)

Qui in sardegna stiamo diventando tutti neri i 50 gradi si fanno sentireeeeeeee....Meno male che esiste la birra

Ho testato il codice nel progetto originale e funge alla grandeeeee...ho adattato la userform cambiando solo il percorso e funziona...

Ora che mi hai aperto la mente ....Mi potresti dire se i codici sotto riportati (((presenti in ogni foglio))posso inserirli in un'unica cartella di lavoro come hai fatto con i nuovi codici...
Hai ragione che quando devo fare una modifica la devo riportare su n fogli presenti....((casinoooo e tempo perso))...

PS se vineni in sardegna sarai mio ospite ....e birra a fiumiiii

di nicola (utente non iscritto) data: 09/08/2017 09:17:42
eccoli

Option Explicit

Private Sub cmdAnnoPrecedente_Click()
frmAnnoPrecedente.Show
End Sub

Private Sub cmdCercaArticolo_Click()
frmRicercaArticoli.Show
End Sub

Private Sub cmdbuyer2_Click()
Dim wbTo As Workbook, wbFrom As Workbook
Dim wsTo As Worksheet, wsFrom, Sh As Worksheet
Dim Finalrow As Long
Dim FinalColumns As Long
Dim Percorso, tex As String
Application.ScreenUpdating = False
Application.EnableEvents = False
Set wbFrom = ThisWorkbook
Set wsFrom = wbFrom.ActiveSheet
Percorso = "\CLUSTERFSSharePiano MarketingDb_MasterDb_Proposta_ordini_buyerDb_promo_buyerDb_miglior_promo.xlsm" 'new
Set wbTo = Application.Workbooks.Open(Percorso)
Set wsTo = wbTo.Worksheets("Promo_buyer")
For Each Sh In wbFrom.Worksheets
    If Sh.Range("D9") > 1 Then
        Finalrow = Sh.Range("D" & Rows.Count).End(xlUp).Row
        If wsTo.Range("a1") = "" Then
            FinalColumns = 1
        Else
            FinalColumns = wsTo.Cells(1, Columns.Count).End(xlToLeft).Column + 1
        End If
        wsTo.Range(wsTo.Cells(1, FinalColumns), wsTo.Cells(Finalrow - 8, FinalColumns)) = Sh.Range("D9:D" & Finalrow).Value
        wsTo.Columns(FinalColumns).NumberFormat = "000000"
        wsTo.Range(wsTo.Cells(1, FinalColumns + 1), wsTo.Cells(Finalrow - 8, FinalColumns + 1)) = Sh.Range("F9:F" & Finalrow).Value
        wsTo.Range(wsTo.Cells(1, FinalColumns + 2), wsTo.Cells(Finalrow - 8, FinalColumns + 2)) = Sh.Range("AC9:AC" & Finalrow).Value
    Else
        If tex = "" Then
            tex = Sh.Name
        Else
            tex = tex & vbCrLf & Sh.Name
        End If
    End If
Next
wbTo.Close (1)
If tex = "" Then
    MsgBox "Volantino importato con successo"
Else
    MsgBox "Impossibile caricare il volantino:" & vbCrLf & tex, vbCritical
End If
Application.ScreenUpdating = True
Application.EnableEvents = True

End Sub

Private Sub cmdbuyer_Click()
Dim wbTo As Workbook, wbFrom As Workbook
Dim wsTo As Worksheet, wsFrom As Worksheet
Dim Finalrow As Long
Dim FinalColumns As Long
Dim Percorso As String
Dim objExcel As Object
Dim tex, tex2 As String
Application.ScreenUpdating = False
Application.EnableEvents = False
Set wbFrom = ThisWorkbook
Set wsFrom = wbFrom.ActiveSheet
Percorso = "\CLUSTERFSSharePiano MarketingDb_MasterDb_Proposta_ordini_buyerDb_promo_buyerDb_miglior_promo.xlsm" 'new
Set objExcel = New Excel.Application
Set wbTo = objExcel.Workbooks.Open(Percorso)
Set wsTo = wbTo.Worksheets("Promo_buyer")
    If wsFrom.Range("D9") > 1 Then
        Finalrow = wsFrom.Range("D" & Rows.Count).End(xlUp).Row
        If wsTo.Range("a1") = "" Then
            FinalColumns = 1
        Else
            FinalColumns = wsTo.Cells(1, Columns.Count).End(xlToLeft).Column + 1
        End If
        wsTo.Range(wsTo.Cells(1, FinalColumns), wsTo.Cells(Finalrow - 8, FinalColumns)) = wsFrom.Range("D9:D" & Finalrow).Value
        wsTo.Columns(FinalColumns).NumberFormat = "000000"
        wsTo.Range(wsTo.Cells(1, FinalColumns + 1), wsTo.Cells(Finalrow - 8, FinalColumns + 1)) = wsFrom.Range("F9:F" & Finalrow).Value
        wsTo.Range(wsTo.Cells(1, FinalColumns + 2), wsTo.Cells(Finalrow - 8, FinalColumns + 2)) = wsFrom.Range("AC9:AC" & Finalrow).Value
        
        MsgBox "Volantino caricato con successo:" & vbCrLf & tex2, vbInformation
        
     Else
        MsgBox "Impossibile caricare il volantino:" & vbCrLf & tex, vbCritical
    End If
wbTo.Close (1)
Application.ScreenUpdating = True
Application.EnableEvents = True

End Sub

Private Sub cmdControllo_Click()
Dim controllo As String
Dim expo As String
Dim richiamo As String
Dim disponibilità As String
Dim prezzi As String
Dim periodo As String
Dim tipo As String
periodo = MsgBox("Hai inserito nella testata le date e i richiami?", vbQuestion + vbYesNo, Title:="Attenzione! Controlla la colonna:master?")
tipo = MsgBox("Hai inserito nella testata il tipo e il tema della promozione?", vbQuestion + vbYesNo, Title:="Attenzione! Controlla la colonna:master?")
controllo = MsgBox("Hai verificato se l'articolo in promo é un master?", vbQuestion + vbYesNo, Title:="Attenzione! Controlla la colonna:master?")
expo = MsgBox("Hai verificato se l'articolo in promo é all'interno di un expo?", vbQuestion + vbYesNo, Title:="Attenzione! Inserisci il codice expo nelle note")
richiamo = MsgBox("Hai inserito nelle note se l'articolo in promo fa parte del richiamo?", vbQuestion + vbYesNo, Title:="Attenzione! Controlla la colonna delle note")
disponibilità = MsgBox("Hai verificato la disponibilità dell'articolo?", vbQuestion + vbYesNo, Title:="Attenzione! Controlla la la giacenza o la data di arrivo")
prezzi = MsgBox("Hai inserito il prezzo promo dell'articolo?", vbQuestion + vbYesNo, Title:="Attenzione! Controlla la colonna prezzi promo vpg")
End Sub

Private Sub cmdData_Click()
frmData.Show
End Sub



Private Sub cmdgrafico_Click()
Dim Unione As Range
Dim c1, c2, c3, c4, c5, c6, c7, c8, c9, c10, c11, c12, c13 As Range
Dim Finalrow As Long
Dim Percorso As String, promo As String

On Error Resume Next

ActiveSheet.Range("$A$8:$AM$2000").AutoFilter Field:=4, Criteria1:="<>"
ActiveSheet.Range("$A$8:$AM$2000").RemoveDuplicates Columns:=5, Header:=xlYes



Finalrow = Cells(Rows.Count, 4).End(xlUp).Row

Set c1 = Range("A1:A" & Finalrow)
Set c2 = Range("B1:B" & Finalrow)
Set c3 = Range("D1:D" & Finalrow)
Set c4 = Range("E1:E" & Finalrow)
Set c5 = Range("F1:F" & Finalrow)
Set c6 = Range("J1:J" & Finalrow)
Set c7 = Range("M1:M" & Finalrow)
Set c8 = Range("P1:P" & Finalrow)
Set c9 = Range("Q1:Q" & Finalrow)
Set c10 = Range("R1:R" & Finalrow)
Set c11 = Range("S1:S" & Finalrow)
Set c12 = Range("AL1:AL" & Finalrow)
Set c13 = Range("AM1:AM" & Finalrow)

Set Unione = Union(c1, c2, c3, c4, c5, c6, c7, c8, c9, c10, c11, c12, c13)

Unione.Copy

Workbooks.Add

Selection.PasteSpecial Paste:=xlPasteValuesAndNumberFormats

promo = InputBox("Salva Con Nome") & ".xlsx"

Percorso = "\CLUSTERFSShareKommerzLAVORI COMMERCIALECarlo_PirchioSaponi_Profumi"

ActiveWorkbook.SaveAs Filename:=Percorso & promo, FileFormat:=xlOpenXMLWorkbook

ActiveWorkbook.Close SaveChanges:=True
   Application.DisplayAlerts = False
ActiveWindow.Close

End Sub


Private Sub cmdmixmargine_Click()
Dim Finalrow As Long
Dim area As Range, area2 As Range
Finalrow = Range("D" & Rows.Count).End(xlUp).Row
Set area = Range("AJ9:AJ" & Finalrow)
Set area2 = Range("AK9:AK" & Finalrow)
[G6] = WorksheetFunction.Sum(area)
[H6] = WorksheetFunction.Sum(area2)
[O6].FormulaR1C1 = "=(RC[-7]-RC[-8])/RC[-7]*100"
End Sub

Private Sub cmdStampa_Click()
frmSeleziona.Show
End Sub

Private Sub cmdStampaControllo_Click()
frmStampaControllo.Show
End Sub

Private Sub cmdStampaOrdini_Click()
frmStampaOrdini.Show
End Sub

Private Sub cmdTema_Click()
frmTema.Show
End Sub

Private Sub cmdTipoVolantino_Click()
frmSceltaVolantino.Show
End Sub

Private Sub cmdFiltraUnivoci_Click()
Range("E9:E2000").AdvancedFilter Action:=xlFilterInPlace, Unique:=True
End Sub
   

Private Sub cmdimporta_Click()
Dim Unione As Range
Dim c1, c2, c3, c4 As Range
Dim Finalrow As Long
Dim Percorso As String

Application.ScreenUpdating = False
Application.EnableEvents = False


Finalrow = Cells(Rows.Count, 4).End(xlUp).Row

Set c1 = Range("D9:D" & Finalrow)
Set c2 = Range("F9:F" & Finalrow)
Set c3 = Range("J9:J" & Finalrow)
Set c4 = Range("Q9:Q" & Finalrow)

Set Unione = Union(c1, c2, c3, c4)

Percorso = "\CLUSTERFSSharePiano MarketingDb_MasterDb_Proposta_promo_pdvDb_promo_generaleDb_Vol_generale.xlsm" 'new
Workbooks.Open (Percorso)
Unione.Copy
Worksheets("Db_promo").Range("A2").PasteSpecial Paste:=xlPasteValues
Application.ScreenUpdating = True
Application.EnableEvents = True
Application.DisplayAlerts = False
ActiveWorkbook.Close SaveChanges:=True
Application.DisplayAlerts = True
End Sub

Private Sub cmdCaricavol_Click()
Dim Unione As Range
Dim c1, c2 As Range
Dim Finalrow As Long
Dim Percorso As String, promo As String

Application.ScreenUpdating = False
Application.EnableEvents = False

Finalrow = Cells(Rows.Count, 4).End(xlUp).Row

Set c1 = Range("D9:D" & Finalrow)
Set c2 = Range("Q9:Q" & Finalrow)


Set Unione = Union(c1, c2)

Unione.Copy

Workbooks.Add

Selection.PasteSpecial Paste:=xlPasteValues

promo = InputBox("Salva Con Nome") & ".csv"

Percorso = "\CLUSTERFSSharePiano MarketingInserimento_promo"

ActiveWorkbook.SaveAs Filename:=Percorso & promo, FileFormat:=xlCSV

Application.ScreenUpdating = True
Application.EnableEvents = True

End Sub

di Vecchio Frac data: 09/08/2017 16:10:35
Forse non ti avevo detto che *tutti* i codici dei singoli fogli relativi agli eventi Worksheet_Change li devi eliminare perchè vengono gestiti tutti dall'evento Workbook_Sheetchange del Workbook.

Analogamente a questo, non devi scrivere lo stesso codice replicandolo nei tuoi fogli: lo scrivi una volta sola, in un modulo pubblico, e da lì il codice è accessibile all'intero progetto. Con qualche avvertenza: se è codice di Form ovviamente no, è relativo al form su cui insistono; se è codice di pulsanti sparpagliati nei vari fogli allora sì, però devi qualificare correttamente i range cui devono riferirsi altrimenti Excel non sa a quale foglio ti riferisci.
Se non vuoi o non puoi allegare qui l'intero progetto allora spediscilo all'indirizzo dello staff (staff@excelvba.it) così ti confermo se puoi generalizzare il contesto (ma credo proprio che si può fare).

cit. "PS se vieni in Sardegna sarai mio ospite ....e birra a fiumiiii"
---> Molto bene, aggiungo la Sardegna alla mia lista... ho inviti in tutta Italia ormai ^_^
di nicola (utente non iscritto) data: 09/08/2017 17:08:08

Mandato all'indirizzo staff@excelvba.it..

Immagino che sei stravoluto bene...sei il Dio del Vba
di Vecchio Frac data: 10/08/2017 15:11:17
@Nicola
ogni tanto ricordami questa discussione visto che mi hai mandato un file (che non ho ancora potuto vedere) altrimenti me ne dimentico.
di nicola (utente non iscritto) data: 10/08/2017 16:40:14
Tranquillo ..

gentilissimooooo

Vuoi Approfondire?