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 |
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 |
sh1 = ActiveSheet.Name -1: sh2 = ActiveSheet.Name + 1prestando 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).
For Each sh In Array(Sheets(ActiveSheet.Name - 1), Sheets(ActiveSheet.Name + 1))
For Each sh In Array(ActiveSheet.Previous, ActiveSheet.Next)).
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.
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 |
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 |
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 |
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 |
'un range multicelle viene ridotto a una cella sola:forzando l'uscita dalla sub in caso di impostazione multicelle...
If Source.Cells.Count > 1 Then Application.EnableEvents=True: Exit Sub
'un range multicelle viene ridotto a una cella sola:forzando l'uscita dalla sub in caso di impostazione multicelle...
If Source.Cells.Count > 1 Then Exit Sub
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 |