Bonjour,
Aprés l'utilisation de certaines macros (et pas à chaque fois même sur les
macros impliquées) Excel en me rendant la main affiche sur le tiers gauche
de
l'écran une barre grise.
Excel considère cette barre comme une barre d'outil (si je clique dessus
il
me propose quel barre ajouter comme sur une barre classique), mais je ne
peux
ni la déplacer ni mettre aucun élément dessus. Et la seule manière que
j'ai
trouvé pour l'enlever est de rédemarer excel.
Est ce un problème connu du à un manque de mémoire (gros fichier plus
grosse
macro) ?
Où un truc dans la macro qui serait anormal ?
Merci d'avance
benjamin
Bonjour,
Aprés l'utilisation de certaines macros (et pas à chaque fois même sur les
macros impliquées) Excel en me rendant la main affiche sur le tiers gauche
de
l'écran une barre grise.
Excel considère cette barre comme une barre d'outil (si je clique dessus
il
me propose quel barre ajouter comme sur une barre classique), mais je ne
peux
ni la déplacer ni mettre aucun élément dessus. Et la seule manière que
j'ai
trouvé pour l'enlever est de rédemarer excel.
Est ce un problème connu du à un manque de mémoire (gros fichier plus
grosse
macro) ?
Où un truc dans la macro qui serait anormal ?
Merci d'avance
benjamin
Bonjour,
Aprés l'utilisation de certaines macros (et pas à chaque fois même sur les
macros impliquées) Excel en me rendant la main affiche sur le tiers gauche
de
l'écran une barre grise.
Excel considère cette barre comme une barre d'outil (si je clique dessus
il
me propose quel barre ajouter comme sur une barre classique), mais je ne
peux
ni la déplacer ni mettre aucun élément dessus. Et la seule manière que
j'ai
trouvé pour l'enlever est de rédemarer excel.
Est ce un problème connu du à un manque de mémoire (gros fichier plus
grosse
macro) ?
Où un truc dans la macro qui serait anormal ?
Merci d'avance
benjamin
Désolé,
Je me suis raté...
il y a 7 mod et une uform. Main, Fnubs, Miseenforme et la uform se lance à
partir d'une feuille.cela plante pour main et uform essentiellement
J'ai pas assez de place donc je ne te mets pas fnubs et miseenforme lol
Si tu n'as pas le courage de chercher dedans je comprendrais lol
donc Main :
Option Explicit
Option Compare Text
Public Const ColNDP = 26
Public Const ColNR = 37
Public Const ColCOS = 51
Public Const ColGM = 52
Public Const ColumnFnubs = 22
Public Const ColumnType = 10
Sub MainMartin()
Dim I As Integer, j As Integer, n As Integer, p As Integer
Dim q As Integer, r As Integer, r1 As Integer, r2 As Integer
Dim r3 As Integer, NumbFileOpen As Integer
Dim nameoffile As String, Msg As String
Dim numblastline As Long, NumbLineProd As Long
Dim VarNewProduct As Variant
Dim tablXX, tablLastLine, tablCheck1, tablcheck2, tablProd As Variant
[f6].Value = 0
[f14:f18].Value = 0
[i31:i32].Value = 0
tablCheck1 = Range(Cells(1, 1), Cells(1, 55)).Value
Sheets("Data").Select
tablcheck2 = Range(Cells(1, 1), Cells(1, 55)).Value
For q = 1 To 55
If tablCheck1(1, q) <> tablcheck2(1, q) Then
MsgBox ("The Columns of the report have changed !")
Exit Sub
End If
Next
FiltreMartin (False) 'ensure also that all lines are visible
n = Workbooks.Count
numblastline = Range("A65536").End(xlUp).Row
'To know the last line used
nameoffile = ActiveWorkbook.Name
'Check that there is no information on a line under the last row
'with a full date cell
tablLastLine = Range(Cells(numblastline + 1, 1), Cells(numblastline +
1,
55)).Value
For p = 1 To 55
If tablLastLine(1, p) <> 0 Then
MsgBox ("Your last line don't have a date on the first" _
& "column. Please fix it")
Exit Sub
End If
Next
Sheets("control").Select
ActiveSheet.Unprotect ("qsdfgh")
Range("b2").Value = numblastline
ActiveSheet.Protect DrawingObjects:=True, Contents:=True,
Scenarios:=True, Password:="qsdfgh"
For j = 1 To n
If Workbooks(j).Name = "Products Reference.xls" Then
'IF Products Reference is open, we moove to the rest
NumbFileOpen = 1
GoTo 1
End If
Next j
'If the adress of the products Reference file is different from
'the one used, the macro end, else we open Products Reference file
On Error GoTo 3
Workbooks.Open ("E:FinancePrivate3_Business_ClientCommercial
Products ReportingBenjamin WIPCR MartinProducts ref MartinProducts
Reference.xls")
Windows(nameoffile).Activate
NumbFileOpen = 2
GoTo 1
1
On Error GoTo 4
FillFnubsAndTypeMartin (numblastline)
'Put formula to calculate Net delaer Price, Net Revenue,
'Cost of Sales and Gross Margin
Cells(2, ColNDP).FormulaR1C1 = "=RC[-1]+RC[-2]"
Cells(2, ColNDP).AutoFill _
Destination:=Range(Cells(2, ColNDP), Cells(numblastline, ColNDP))
Cells(2, ColNR - 2).FormulaR1C1 = "=RC[-1]+RC[-2]"
Cells(2, ColNR - 1).FormulaR1C1 = "=control!R47C6*RC[1]"
Cells(2, ColNR).FormulaR1C1 = "=sum(RC[-11]:RC[-3])"
Range(Cells(2, ColNR - 2), Cells(2, ColNR)).AutoFill _
Destination:=Range(Cells(2, ColNR - 2), Cells(numblastline, ColNR))
Cells(2, ColCOS - 3).FormulaR1C1 =
"=RC[-10]+RC[-5]+RC[-3]+RC[-2]+RC[-1]"
Cells(2, ColCOS - 2).FormulaR1C1 = "=RC[-7]+RC[-5]"
Cells(2, ColCOS - 1).FormulaR1C1 = "=control!R48C6*RC[1]"
Cells(2, ColCOS).FormulaR1C1 = "=sum(RC[-13]:RC[-4])"
Cells(2, ColGM).FormulaR1C1 = "=RC[-15]-RC[-1]"
Cells(2, ColGM + 1).FormulaR1C1 = "=Rc[-16]+RC[-17]"
Cells(2, ColGM + 2).FormulaR1C1 = "=Rc[-4]+RC[-3]"
Cells(2, ColGM + 3).FormulaR1C1 = "=Rc[-2]-RC[-1]"
Range(Cells(2, ColCOS - 3), Cells(2, ColGM + 3)).AutoFill _
Destination:=Range(Cells(2, ColCOS - 3), Cells(numblastline, ColGM
+
3))
Application.CalculateFull
'Break Vlookup link to be easier to use
ActiveWorkbook.BreakLink
Name:="E:FinancePrivate3_Business_ClientCommercial Products
ReportingBenjamin WIPCR MartinProducts ref MartinProducts
Reference.xls",
Type:=xlExcelLinks
'Put out formula on FNUbs, Account unit, Extended Account unit
' and type column without xx
Range(Cells(2, ColumnFnubs), Cells(numblastline, ColumnFnubs + 1)).Copy
Cells(2, ColumnFnubs).Select: Selection.PasteSpecial xlValues
Application.Calculation = xlCalculationAutomatic
FiltreMartin (True)
'filter TYPE = NA
Selection.AutoFilter field:, Criteria1:="#N/A"
For Each VarNewProduct In Range("K2",
[K65536].End(xlUp)).SpecialCells(xlCellTypeVisible)
If VarNewProduct.Row = 1 Then
ActiveSheet.ShowAllData
'If there is no new products, we show all data and
'close Products Reference file
GoTo 2
End If
Exit For
Next
'If there is news products then we copy it in the file Products
Reference
Application.ScreenUpdating = True
Range(Cells(2, 5), Cells(numblastline,
5)).SpecialCells(xlCellTypeVisible).Copy
Windows("Products Reference.xls").Activate
Sheets("Products").Select
NumbLineProd = [a65536].End(xlUp).Row
Cells(NumbLineProd + 1, 1).Select: Selection.PasteSpecial xlValues
Windows(nameoffile).Activate
Range(Cells(2, 6), Cells(numblastline,
6)).SpecialCells(xlCellTypeVisible).Copy
Windows("Products Reference.xls").Activate
Cells(NumbLineProd + 1, 3).Select: Selection.PasteSpecial xlValues
Windows(nameoffile).Activate
Range(Cells(2, 9), Cells(numblastline,
9)).SpecialCells(xlCellTypeVisible).Copy
Windows("Products Reference.xls").Activate
Cells(NumbLineProd + 1, 2).Select: Selection.PasteSpecial xlValues
Windows(nameoffile).Activate
Range(Cells(2, ColumnType), Cells(numblastline,
ColumnType)).SpecialCells(xlCellTypeVisible).Copy
Cells(VarNewProduct.Row, 1).Select
Windows("Products Reference.xls").Activate
Cells(NumbLineProd + 1, 7).Select: Selection.PasteSpecial xlValues
If [a65536].End(xlUp).Row - NumbLineProd > 1 Then
r2 = r3 = 0
tablProd = Range(Cells(NumbLineProd + 1, 1),
Cells([a65536].End(xlUp).Row, 1)).Value
For r = 2 To [a65536].End(xlUp).Row - NumbLineProd
For r1 = 1 To r - 1
r2 = 0
If tablProd(r, 1) = tablProd(r1, 1) Then
r2 = 1
Exit For
End If
Next r1
If r2 = 1 Then
Cells(NumbLineProd + r - r3, 1).EntireRow.Delete
r3 = r3 + 1
End If
Next r
End If
Cells(NumbLineProd + 1, 1).Select
Windows(nameoffile).Activate
Sheets("data").Select
On Error Resume Next
ActiveSheet.Protection.AllowEditRanges(1).Delete
ActiveSheet.Protection.AllowEditRanges(1).Delete
ActiveSheet.Protection.AllowEditRanges.Add Title:="Range2", Range:= _
Range("A2", [BC65536].End(xlUp)).SpecialCells(xlCellTypeVisible)
ProtectionMartin (numblastline)
Sheets("pivot").Select
ActiveSheet.PivotTables("PivotTable2").PivotCache.Refresh
Sheets("Manual adjustement pivot").Select
ActiveSheet.PivotTables("PivotTable3").PivotCache.Refresh
Sheets("data").Select
Exit Sub
2
'If Procuts file was close at start, we reclose it
If NumbFileOpen = 2 Then
Workbooks("Products Reference.xls").Save
Windows("Products Reference.xls").Close
Windows(nameoffile).Activate
End If
ProtectionMartin (numblastline)
Application.ScreenUpdating = True
[A2].Select
Sheets("pivot").Select
ActiveSheet.PivotTables("PivotTable2").PivotCache.Refresh
Sheets("Manual adjustement pivot").Select
ActiveSheet.PivotTables("PivotTable3").PivotCache.Refresh
Sheets("data").Select
Exit Sub
3
MsgBox ("The adress of the file of the Products Reference is not good."
_
& "Please look at it before launching the macro again.")
4
Msg = "Error # " & Str(Err.Number) & " was generated by " _
& Err.Source & Chr(13) & Err.Description
MsgBox Msg, , "Error"
End Sub
autofilter :
Option Explicit
Sub FiltreMartin(bmode As Boolean)
If ActiveSheet.AutoFilterMode Then
'Autofilter is on
If Not bmode Then
'wants to turn it off... but warning if filter active, lines would
be hidden
Rows("1:1").Select
On Error Resume Next
ActiveSheet.ShowAllData
Selection.AutoFilter
End If
Else
'Autofilter is off
If bmode Then
'Turn is on
Rows("1:1").Select
Selection.AutoFilter
End If
End If
End Sub
FIll fnubs and type :
Public Const ColumnFnubs = 22
Public Const ColumnType = 10
Sub FillFnubsAndTypeMartin(numblastline As Long)
Application.Calculation = xlManual
Application.ScreenUpdating = False
Sheets("data").Select
ActiveSheet.Unprotect ("qsdfgh")
'Replace FNUBS by Formula
Cells(2, ColumnFnubs).FormulaR1C1 > "=IF(RC[-11]=""PC"",RC[-1],IF(RC[-11]=""TC"",RC[-1],IF(RC[-11]=""AV
PC"",RC[-1],if(RC[-11]=""ALC PC"",RC[-1],0))))"
Cells(2, ColumnFnubs).AutoFill Destination:=Range(Cells(2,
ColumnFnubs), _
Cells(numblastline, ColumnFnubs))
Cells(2, ColumnFnubs + 1).FormulaR1C1 > "=IF(RC[-12]=""Monitor"",RC[-2],0)"
Cells(2, ColumnFnubs + 1).AutoFill Destination:=Range(Cells(2,
ColumnFnubs + 1), _
Cells(numblastline, ColumnFnubs + 1))
'Research in Products Reference File of the Extended Type
'and Simplified Family of each poduct
Cells(2, ColumnType + 1).FormulaR1C1 = _
"=VLOOKUP(RC[-6],'[Products Reference.xls]Products'!C1:C6,4,FALSE)"
Cells(2, ColumnType + 2).FormulaR1C1 = _
"=VLOOKUP(RC[-7],'[Products Reference.xls]Products'!C1:C6,5,FALSE)"
Cells(2, ColumnType + 3).FormulaR1C1 = _
"=VLOOKUP(RC[-8],'[Products Reference.xls]Products'!C1:C6,6,FALSE)"
Range(Cells(2, ColumnType + 1), Cells(2, ColumnType + 3)).AutoFill _
Destination:=Range(Cells(2, ColumnType + 1), Cells(numblastline,
ColumnType + 3))
End Sub
Protcetion :
Sub ProtectionMartin(numblastline As Double)
On Error Resume Next
ActiveSheet.Protection.AllowEditRanges.Add Title:="Range1", Range:= _
Range(Cells(numblastline, 1), Cells(numblastline + 1000, 256))
ActiveSheet.Protect DrawingObjects:=True, Contents:=True, Scenarios:=True
_
, AllowSorting:=True, AllowFiltering:=True,
AllowUsingPivotTables:=True,
Password:="qsdfgh"
End Sub
Userform :
Private Sub UserForm_Activate()
Dim n, q, p As Integer
Dim VarNewProduct As Variant
Windows("new mec martin.xls").Activate
Sheets("data").Select
Application.Calculation = xlManual
Application.ScreenUpdating = False
ActiveSheet.Unprotect ("qsdfgh")
FiltreMartin ("true")
Selection.AutoFilter field:, Criteria1:="<>"
n = 1
p = 0
For Each VarNewProduct In Range("O2",
[O65536].End(xlUp)).SpecialCells(xlCellTypeVisible)
If VarNewProduct.Value <> "" And VarNewProduct.Value <> "Manual Label"
Then
If n <> 1 Then
For q = 1 To n - 1
If VarNewProduct.Value = Controls("checkbox" & q).Caption
Then
GoTo 1
End If
Next
End If
Controls("checkbox" & n).Caption = VarNewProduct.Value
Controls("checkbox" & n).Visible = True
n = n + 1
p = 1
End If
1
Next
If p = 0 Then
Unload Me
MsgBox ("There is no Manual correction !")
Sheets("control").Select
Range("e47").Value = [sum(data!AK:Ak)] - [sumif(data!b:b;"hp
europe";ak:ak)]
Range("e48").Value = [sum(data!AY:AY)] - [sumif(data!b:b;"hp
europe";ay:ay)]
Range("f20:f21").Calculate
Sheets("data").Select
ActiveSheet.ShowAllData
Cells(2, 34).FormulaR1C1 = "=control!R20C6*RC[1]"
Cells(2, 34).AutoFill Destination:=Range(Cells(2, 34),
[AH65536].End(xlUp))
Cells(2, 46).FormulaR1C1 = "=control!R21C6*RC[1]"
Cells(2, 46).AutoFill Destination:=Range(Cells(2, 46),
[AT65536].End(xlUp))
Columns("ah:ah").Calculate
Columns("at:at").Calculate
Columns("aw:ay").Calculate
Sheets("control").Select
Selection.Calculate
Application.Calculation = xlAutomatic
Application.ScreenUpdating = True
ProtectionMartin ([a65536].End(xlUp).Row)
End If
If n > 2 Then
For r = 1 To n - 1
If r Mod 2 = 1 Then
Controls("checkbox" & r).Left = 24
Else
Controls("checkbox" & r).Left = 144
End If
Controls("checkbox" & r).Top = 72 + Round(r / 2 - 0.9, 0) * 30
Next
UserFormMartin.Height = 167 + 30 * Round(r / 2 - 0.9, 0)
Cb_ok.Top = 102 + Round(r / 2 - 0.9, 0) * 30
Cb_cancel2.Top = 102 + Round(r / 2 - 0.9, 0) * 30
End If
End Sub
Private Sub Cb_cancel_Click()
Unload Me
End Sub
Private Sub CB_ok_Click()
Dim dblsum, dblsumalnr, dblsumalcos As Double
Dim Ctrl As Variant
UserFormMartin.Hide
Sheets("data").Select
Cells(2, 36).FormulaR1C1 = "=control!R47C6*RC[1]"
Cells(2, 36).AutoFill Destination:=Range(Cells(2, 36),
[AJ65536].End(xlUp))
Cells(2, 50).FormulaR1C1 = "=control!R48C6*RC[1]"
Cells(2, 50).AutoFill Destination:=Range(Cells(2, 50),
[AX65536].End(xlUp))
FiltreMartin ("true")
Selection.AutoFilter field:, Criteria1:="<>"
Selection.AutoFilter field:=2, Criteria1:="<>HP Europe", Operator:=xlAnd
dblsumnr = dblsumcos = 0
For Each Ctrl In UserFormMartin.Controls
If TypeName(Ctrl) = "CheckBox" Then
If Ctrl.Value = True Then
For Each cell In Range("O2",
[O65536].End(xlUp)).SpecialCells(xlCellTypeVisible)
If cell.Value = Ctrl.Caption Then
dblsumnr = dblsumnr + cell.Offset(0, 22).Value
dblsumcos = dblsumcos + cell.Offset(0, 36).Value
cell.Offset(0, 21).Value = 0
cell.Offset(0, 35).Value = 0
End If
Next
End If
End If
Next
dblsumalnr = [sum(AK:Ak)] - dblsumnr - [sumif(b:b,"HP Europe",Ak:Ak)]
dblsumalcos = [sum(AY:AY)] - dblsumcos - [sumif(b:b,"HP Europe",Ay:Ay)]
Sheets("control").Select
Range("e47").Value = dblsumalnr
Range("e48").Value = dblsumalcos
Unload UserFormMartin
Sheets("data").Select
Columns("aj:aj").Calculate
Columns("ax:ax").Calculate
Columns("ba:bc").Calculate
Application.Calculation = xlAutomatic
Application.ScreenUpdating = True
ProtectionMartin ([a65536].End(xlUp).Row)
End Sub
Désolé,
Je me suis raté...
il y a 7 mod et une uform. Main, Fnubs, Miseenforme et la uform se lance à
partir d'une feuille.cela plante pour main et uform essentiellement
J'ai pas assez de place donc je ne te mets pas fnubs et miseenforme lol
Si tu n'as pas le courage de chercher dedans je comprendrais lol
donc Main :
Option Explicit
Option Compare Text
Public Const ColNDP = 26
Public Const ColNR = 37
Public Const ColCOS = 51
Public Const ColGM = 52
Public Const ColumnFnubs = 22
Public Const ColumnType = 10
Sub MainMartin()
Dim I As Integer, j As Integer, n As Integer, p As Integer
Dim q As Integer, r As Integer, r1 As Integer, r2 As Integer
Dim r3 As Integer, NumbFileOpen As Integer
Dim nameoffile As String, Msg As String
Dim numblastline As Long, NumbLineProd As Long
Dim VarNewProduct As Variant
Dim tablXX, tablLastLine, tablCheck1, tablcheck2, tablProd As Variant
[f6].Value = 0
[f14:f18].Value = 0
[i31:i32].Value = 0
tablCheck1 = Range(Cells(1, 1), Cells(1, 55)).Value
Sheets("Data").Select
tablcheck2 = Range(Cells(1, 1), Cells(1, 55)).Value
For q = 1 To 55
If tablCheck1(1, q) <> tablcheck2(1, q) Then
MsgBox ("The Columns of the report have changed !")
Exit Sub
End If
Next
FiltreMartin (False) 'ensure also that all lines are visible
n = Workbooks.Count
numblastline = Range("A65536").End(xlUp).Row
'To know the last line used
nameoffile = ActiveWorkbook.Name
'Check that there is no information on a line under the last row
'with a full date cell
tablLastLine = Range(Cells(numblastline + 1, 1), Cells(numblastline +
1,
55)).Value
For p = 1 To 55
If tablLastLine(1, p) <> 0 Then
MsgBox ("Your last line don't have a date on the first" _
& "column. Please fix it")
Exit Sub
End If
Next
Sheets("control").Select
ActiveSheet.Unprotect ("qsdfgh")
Range("b2").Value = numblastline
ActiveSheet.Protect DrawingObjects:=True, Contents:=True,
Scenarios:=True, Password:="qsdfgh"
For j = 1 To n
If Workbooks(j).Name = "Products Reference.xls" Then
'IF Products Reference is open, we moove to the rest
NumbFileOpen = 1
GoTo 1
End If
Next j
'If the adress of the products Reference file is different from
'the one used, the macro end, else we open Products Reference file
On Error GoTo 3
Workbooks.Open ("E:FinancePrivate3_Business_ClientCommercial
Products ReportingBenjamin WIPCR MartinProducts ref MartinProducts
Reference.xls")
Windows(nameoffile).Activate
NumbFileOpen = 2
GoTo 1
1
On Error GoTo 4
FillFnubsAndTypeMartin (numblastline)
'Put formula to calculate Net delaer Price, Net Revenue,
'Cost of Sales and Gross Margin
Cells(2, ColNDP).FormulaR1C1 = "=RC[-1]+RC[-2]"
Cells(2, ColNDP).AutoFill _
Destination:=Range(Cells(2, ColNDP), Cells(numblastline, ColNDP))
Cells(2, ColNR - 2).FormulaR1C1 = "=RC[-1]+RC[-2]"
Cells(2, ColNR - 1).FormulaR1C1 = "=control!R47C6*RC[1]"
Cells(2, ColNR).FormulaR1C1 = "=sum(RC[-11]:RC[-3])"
Range(Cells(2, ColNR - 2), Cells(2, ColNR)).AutoFill _
Destination:=Range(Cells(2, ColNR - 2), Cells(numblastline, ColNR))
Cells(2, ColCOS - 3).FormulaR1C1 =
"=RC[-10]+RC[-5]+RC[-3]+RC[-2]+RC[-1]"
Cells(2, ColCOS - 2).FormulaR1C1 = "=RC[-7]+RC[-5]"
Cells(2, ColCOS - 1).FormulaR1C1 = "=control!R48C6*RC[1]"
Cells(2, ColCOS).FormulaR1C1 = "=sum(RC[-13]:RC[-4])"
Cells(2, ColGM).FormulaR1C1 = "=RC[-15]-RC[-1]"
Cells(2, ColGM + 1).FormulaR1C1 = "=Rc[-16]+RC[-17]"
Cells(2, ColGM + 2).FormulaR1C1 = "=Rc[-4]+RC[-3]"
Cells(2, ColGM + 3).FormulaR1C1 = "=Rc[-2]-RC[-1]"
Range(Cells(2, ColCOS - 3), Cells(2, ColGM + 3)).AutoFill _
Destination:=Range(Cells(2, ColCOS - 3), Cells(numblastline, ColGM
+
3))
Application.CalculateFull
'Break Vlookup link to be easier to use
ActiveWorkbook.BreakLink
Name:="E:FinancePrivate3_Business_ClientCommercial Products
ReportingBenjamin WIPCR MartinProducts ref MartinProducts
Reference.xls",
Type:=xlExcelLinks
'Put out formula on FNUbs, Account unit, Extended Account unit
' and type column without xx
Range(Cells(2, ColumnFnubs), Cells(numblastline, ColumnFnubs + 1)).Copy
Cells(2, ColumnFnubs).Select: Selection.PasteSpecial xlValues
Application.Calculation = xlCalculationAutomatic
FiltreMartin (True)
'filter TYPE = NA
Selection.AutoFilter field:, Criteria1:="#N/A"
For Each VarNewProduct In Range("K2",
[K65536].End(xlUp)).SpecialCells(xlCellTypeVisible)
If VarNewProduct.Row = 1 Then
ActiveSheet.ShowAllData
'If there is no new products, we show all data and
'close Products Reference file
GoTo 2
End If
Exit For
Next
'If there is news products then we copy it in the file Products
Reference
Application.ScreenUpdating = True
Range(Cells(2, 5), Cells(numblastline,
5)).SpecialCells(xlCellTypeVisible).Copy
Windows("Products Reference.xls").Activate
Sheets("Products").Select
NumbLineProd = [a65536].End(xlUp).Row
Cells(NumbLineProd + 1, 1).Select: Selection.PasteSpecial xlValues
Windows(nameoffile).Activate
Range(Cells(2, 6), Cells(numblastline,
6)).SpecialCells(xlCellTypeVisible).Copy
Windows("Products Reference.xls").Activate
Cells(NumbLineProd + 1, 3).Select: Selection.PasteSpecial xlValues
Windows(nameoffile).Activate
Range(Cells(2, 9), Cells(numblastline,
9)).SpecialCells(xlCellTypeVisible).Copy
Windows("Products Reference.xls").Activate
Cells(NumbLineProd + 1, 2).Select: Selection.PasteSpecial xlValues
Windows(nameoffile).Activate
Range(Cells(2, ColumnType), Cells(numblastline,
ColumnType)).SpecialCells(xlCellTypeVisible).Copy
Cells(VarNewProduct.Row, 1).Select
Windows("Products Reference.xls").Activate
Cells(NumbLineProd + 1, 7).Select: Selection.PasteSpecial xlValues
If [a65536].End(xlUp).Row - NumbLineProd > 1 Then
r2 = r3 = 0
tablProd = Range(Cells(NumbLineProd + 1, 1),
Cells([a65536].End(xlUp).Row, 1)).Value
For r = 2 To [a65536].End(xlUp).Row - NumbLineProd
For r1 = 1 To r - 1
r2 = 0
If tablProd(r, 1) = tablProd(r1, 1) Then
r2 = 1
Exit For
End If
Next r1
If r2 = 1 Then
Cells(NumbLineProd + r - r3, 1).EntireRow.Delete
r3 = r3 + 1
End If
Next r
End If
Cells(NumbLineProd + 1, 1).Select
Windows(nameoffile).Activate
Sheets("data").Select
On Error Resume Next
ActiveSheet.Protection.AllowEditRanges(1).Delete
ActiveSheet.Protection.AllowEditRanges(1).Delete
ActiveSheet.Protection.AllowEditRanges.Add Title:="Range2", Range:= _
Range("A2", [BC65536].End(xlUp)).SpecialCells(xlCellTypeVisible)
ProtectionMartin (numblastline)
Sheets("pivot").Select
ActiveSheet.PivotTables("PivotTable2").PivotCache.Refresh
Sheets("Manual adjustement pivot").Select
ActiveSheet.PivotTables("PivotTable3").PivotCache.Refresh
Sheets("data").Select
Exit Sub
2
'If Procuts file was close at start, we reclose it
If NumbFileOpen = 2 Then
Workbooks("Products Reference.xls").Save
Windows("Products Reference.xls").Close
Windows(nameoffile).Activate
End If
ProtectionMartin (numblastline)
Application.ScreenUpdating = True
[A2].Select
Sheets("pivot").Select
ActiveSheet.PivotTables("PivotTable2").PivotCache.Refresh
Sheets("Manual adjustement pivot").Select
ActiveSheet.PivotTables("PivotTable3").PivotCache.Refresh
Sheets("data").Select
Exit Sub
3
MsgBox ("The adress of the file of the Products Reference is not good."
_
& "Please look at it before launching the macro again.")
4
Msg = "Error # " & Str(Err.Number) & " was generated by " _
& Err.Source & Chr(13) & Err.Description
MsgBox Msg, , "Error"
End Sub
autofilter :
Option Explicit
Sub FiltreMartin(bmode As Boolean)
If ActiveSheet.AutoFilterMode Then
'Autofilter is on
If Not bmode Then
'wants to turn it off... but warning if filter active, lines would
be hidden
Rows("1:1").Select
On Error Resume Next
ActiveSheet.ShowAllData
Selection.AutoFilter
End If
Else
'Autofilter is off
If bmode Then
'Turn is on
Rows("1:1").Select
Selection.AutoFilter
End If
End If
End Sub
FIll fnubs and type :
Public Const ColumnFnubs = 22
Public Const ColumnType = 10
Sub FillFnubsAndTypeMartin(numblastline As Long)
Application.Calculation = xlManual
Application.ScreenUpdating = False
Sheets("data").Select
ActiveSheet.Unprotect ("qsdfgh")
'Replace FNUBS by Formula
Cells(2, ColumnFnubs).FormulaR1C1 > "=IF(RC[-11]=""PC"",RC[-1],IF(RC[-11]=""TC"",RC[-1],IF(RC[-11]=""AV
PC"",RC[-1],if(RC[-11]=""ALC PC"",RC[-1],0))))"
Cells(2, ColumnFnubs).AutoFill Destination:=Range(Cells(2,
ColumnFnubs), _
Cells(numblastline, ColumnFnubs))
Cells(2, ColumnFnubs + 1).FormulaR1C1 > "=IF(RC[-12]=""Monitor"",RC[-2],0)"
Cells(2, ColumnFnubs + 1).AutoFill Destination:=Range(Cells(2,
ColumnFnubs + 1), _
Cells(numblastline, ColumnFnubs + 1))
'Research in Products Reference File of the Extended Type
'and Simplified Family of each poduct
Cells(2, ColumnType + 1).FormulaR1C1 = _
"=VLOOKUP(RC[-6],'[Products Reference.xls]Products'!C1:C6,4,FALSE)"
Cells(2, ColumnType + 2).FormulaR1C1 = _
"=VLOOKUP(RC[-7],'[Products Reference.xls]Products'!C1:C6,5,FALSE)"
Cells(2, ColumnType + 3).FormulaR1C1 = _
"=VLOOKUP(RC[-8],'[Products Reference.xls]Products'!C1:C6,6,FALSE)"
Range(Cells(2, ColumnType + 1), Cells(2, ColumnType + 3)).AutoFill _
Destination:=Range(Cells(2, ColumnType + 1), Cells(numblastline,
ColumnType + 3))
End Sub
Protcetion :
Sub ProtectionMartin(numblastline As Double)
On Error Resume Next
ActiveSheet.Protection.AllowEditRanges.Add Title:="Range1", Range:= _
Range(Cells(numblastline, 1), Cells(numblastline + 1000, 256))
ActiveSheet.Protect DrawingObjects:=True, Contents:=True, Scenarios:=True
_
, AllowSorting:=True, AllowFiltering:=True,
AllowUsingPivotTables:=True,
Password:="qsdfgh"
End Sub
Userform :
Private Sub UserForm_Activate()
Dim n, q, p As Integer
Dim VarNewProduct As Variant
Windows("new mec martin.xls").Activate
Sheets("data").Select
Application.Calculation = xlManual
Application.ScreenUpdating = False
ActiveSheet.Unprotect ("qsdfgh")
FiltreMartin ("true")
Selection.AutoFilter field:, Criteria1:="<>"
n = 1
p = 0
For Each VarNewProduct In Range("O2",
[O65536].End(xlUp)).SpecialCells(xlCellTypeVisible)
If VarNewProduct.Value <> "" And VarNewProduct.Value <> "Manual Label"
Then
If n <> 1 Then
For q = 1 To n - 1
If VarNewProduct.Value = Controls("checkbox" & q).Caption
Then
GoTo 1
End If
Next
End If
Controls("checkbox" & n).Caption = VarNewProduct.Value
Controls("checkbox" & n).Visible = True
n = n + 1
p = 1
End If
1
Next
If p = 0 Then
Unload Me
MsgBox ("There is no Manual correction !")
Sheets("control").Select
Range("e47").Value = [sum(data!AK:Ak)] - [sumif(data!b:b;"hp
europe";ak:ak)]
Range("e48").Value = [sum(data!AY:AY)] - [sumif(data!b:b;"hp
europe";ay:ay)]
Range("f20:f21").Calculate
Sheets("data").Select
ActiveSheet.ShowAllData
Cells(2, 34).FormulaR1C1 = "=control!R20C6*RC[1]"
Cells(2, 34).AutoFill Destination:=Range(Cells(2, 34),
[AH65536].End(xlUp))
Cells(2, 46).FormulaR1C1 = "=control!R21C6*RC[1]"
Cells(2, 46).AutoFill Destination:=Range(Cells(2, 46),
[AT65536].End(xlUp))
Columns("ah:ah").Calculate
Columns("at:at").Calculate
Columns("aw:ay").Calculate
Sheets("control").Select
Selection.Calculate
Application.Calculation = xlAutomatic
Application.ScreenUpdating = True
ProtectionMartin ([a65536].End(xlUp).Row)
End If
If n > 2 Then
For r = 1 To n - 1
If r Mod 2 = 1 Then
Controls("checkbox" & r).Left = 24
Else
Controls("checkbox" & r).Left = 144
End If
Controls("checkbox" & r).Top = 72 + Round(r / 2 - 0.9, 0) * 30
Next
UserFormMartin.Height = 167 + 30 * Round(r / 2 - 0.9, 0)
Cb_ok.Top = 102 + Round(r / 2 - 0.9, 0) * 30
Cb_cancel2.Top = 102 + Round(r / 2 - 0.9, 0) * 30
End If
End Sub
Private Sub Cb_cancel_Click()
Unload Me
End Sub
Private Sub CB_ok_Click()
Dim dblsum, dblsumalnr, dblsumalcos As Double
Dim Ctrl As Variant
UserFormMartin.Hide
Sheets("data").Select
Cells(2, 36).FormulaR1C1 = "=control!R47C6*RC[1]"
Cells(2, 36).AutoFill Destination:=Range(Cells(2, 36),
[AJ65536].End(xlUp))
Cells(2, 50).FormulaR1C1 = "=control!R48C6*RC[1]"
Cells(2, 50).AutoFill Destination:=Range(Cells(2, 50),
[AX65536].End(xlUp))
FiltreMartin ("true")
Selection.AutoFilter field:, Criteria1:="<>"
Selection.AutoFilter field:=2, Criteria1:="<>HP Europe", Operator:=xlAnd
dblsumnr = dblsumcos = 0
For Each Ctrl In UserFormMartin.Controls
If TypeName(Ctrl) = "CheckBox" Then
If Ctrl.Value = True Then
For Each cell In Range("O2",
[O65536].End(xlUp)).SpecialCells(xlCellTypeVisible)
If cell.Value = Ctrl.Caption Then
dblsumnr = dblsumnr + cell.Offset(0, 22).Value
dblsumcos = dblsumcos + cell.Offset(0, 36).Value
cell.Offset(0, 21).Value = 0
cell.Offset(0, 35).Value = 0
End If
Next
End If
End If
Next
dblsumalnr = [sum(AK:Ak)] - dblsumnr - [sumif(b:b,"HP Europe",Ak:Ak)]
dblsumalcos = [sum(AY:AY)] - dblsumcos - [sumif(b:b,"HP Europe",Ay:Ay)]
Sheets("control").Select
Range("e47").Value = dblsumalnr
Range("e48").Value = dblsumalcos
Unload UserFormMartin
Sheets("data").Select
Columns("aj:aj").Calculate
Columns("ax:ax").Calculate
Columns("ba:bc").Calculate
Application.Calculation = xlAutomatic
Application.ScreenUpdating = True
ProtectionMartin ([a65536].End(xlUp).Row)
End Sub
Désolé,
Je me suis raté...
il y a 7 mod et une uform. Main, Fnubs, Miseenforme et la uform se lance à
partir d'une feuille.cela plante pour main et uform essentiellement
J'ai pas assez de place donc je ne te mets pas fnubs et miseenforme lol
Si tu n'as pas le courage de chercher dedans je comprendrais lol
donc Main :
Option Explicit
Option Compare Text
Public Const ColNDP = 26
Public Const ColNR = 37
Public Const ColCOS = 51
Public Const ColGM = 52
Public Const ColumnFnubs = 22
Public Const ColumnType = 10
Sub MainMartin()
Dim I As Integer, j As Integer, n As Integer, p As Integer
Dim q As Integer, r As Integer, r1 As Integer, r2 As Integer
Dim r3 As Integer, NumbFileOpen As Integer
Dim nameoffile As String, Msg As String
Dim numblastline As Long, NumbLineProd As Long
Dim VarNewProduct As Variant
Dim tablXX, tablLastLine, tablCheck1, tablcheck2, tablProd As Variant
[f6].Value = 0
[f14:f18].Value = 0
[i31:i32].Value = 0
tablCheck1 = Range(Cells(1, 1), Cells(1, 55)).Value
Sheets("Data").Select
tablcheck2 = Range(Cells(1, 1), Cells(1, 55)).Value
For q = 1 To 55
If tablCheck1(1, q) <> tablcheck2(1, q) Then
MsgBox ("The Columns of the report have changed !")
Exit Sub
End If
Next
FiltreMartin (False) 'ensure also that all lines are visible
n = Workbooks.Count
numblastline = Range("A65536").End(xlUp).Row
'To know the last line used
nameoffile = ActiveWorkbook.Name
'Check that there is no information on a line under the last row
'with a full date cell
tablLastLine = Range(Cells(numblastline + 1, 1), Cells(numblastline +
1,
55)).Value
For p = 1 To 55
If tablLastLine(1, p) <> 0 Then
MsgBox ("Your last line don't have a date on the first" _
& "column. Please fix it")
Exit Sub
End If
Next
Sheets("control").Select
ActiveSheet.Unprotect ("qsdfgh")
Range("b2").Value = numblastline
ActiveSheet.Protect DrawingObjects:=True, Contents:=True,
Scenarios:=True, Password:="qsdfgh"
For j = 1 To n
If Workbooks(j).Name = "Products Reference.xls" Then
'IF Products Reference is open, we moove to the rest
NumbFileOpen = 1
GoTo 1
End If
Next j
'If the adress of the products Reference file is different from
'the one used, the macro end, else we open Products Reference file
On Error GoTo 3
Workbooks.Open ("E:FinancePrivate3_Business_ClientCommercial
Products ReportingBenjamin WIPCR MartinProducts ref MartinProducts
Reference.xls")
Windows(nameoffile).Activate
NumbFileOpen = 2
GoTo 1
1
On Error GoTo 4
FillFnubsAndTypeMartin (numblastline)
'Put formula to calculate Net delaer Price, Net Revenue,
'Cost of Sales and Gross Margin
Cells(2, ColNDP).FormulaR1C1 = "=RC[-1]+RC[-2]"
Cells(2, ColNDP).AutoFill _
Destination:=Range(Cells(2, ColNDP), Cells(numblastline, ColNDP))
Cells(2, ColNR - 2).FormulaR1C1 = "=RC[-1]+RC[-2]"
Cells(2, ColNR - 1).FormulaR1C1 = "=control!R47C6*RC[1]"
Cells(2, ColNR).FormulaR1C1 = "=sum(RC[-11]:RC[-3])"
Range(Cells(2, ColNR - 2), Cells(2, ColNR)).AutoFill _
Destination:=Range(Cells(2, ColNR - 2), Cells(numblastline, ColNR))
Cells(2, ColCOS - 3).FormulaR1C1 =
"=RC[-10]+RC[-5]+RC[-3]+RC[-2]+RC[-1]"
Cells(2, ColCOS - 2).FormulaR1C1 = "=RC[-7]+RC[-5]"
Cells(2, ColCOS - 1).FormulaR1C1 = "=control!R48C6*RC[1]"
Cells(2, ColCOS).FormulaR1C1 = "=sum(RC[-13]:RC[-4])"
Cells(2, ColGM).FormulaR1C1 = "=RC[-15]-RC[-1]"
Cells(2, ColGM + 1).FormulaR1C1 = "=Rc[-16]+RC[-17]"
Cells(2, ColGM + 2).FormulaR1C1 = "=Rc[-4]+RC[-3]"
Cells(2, ColGM + 3).FormulaR1C1 = "=Rc[-2]-RC[-1]"
Range(Cells(2, ColCOS - 3), Cells(2, ColGM + 3)).AutoFill _
Destination:=Range(Cells(2, ColCOS - 3), Cells(numblastline, ColGM
+
3))
Application.CalculateFull
'Break Vlookup link to be easier to use
ActiveWorkbook.BreakLink
Name:="E:FinancePrivate3_Business_ClientCommercial Products
ReportingBenjamin WIPCR MartinProducts ref MartinProducts
Reference.xls",
Type:=xlExcelLinks
'Put out formula on FNUbs, Account unit, Extended Account unit
' and type column without xx
Range(Cells(2, ColumnFnubs), Cells(numblastline, ColumnFnubs + 1)).Copy
Cells(2, ColumnFnubs).Select: Selection.PasteSpecial xlValues
Application.Calculation = xlCalculationAutomatic
FiltreMartin (True)
'filter TYPE = NA
Selection.AutoFilter field:, Criteria1:="#N/A"
For Each VarNewProduct In Range("K2",
[K65536].End(xlUp)).SpecialCells(xlCellTypeVisible)
If VarNewProduct.Row = 1 Then
ActiveSheet.ShowAllData
'If there is no new products, we show all data and
'close Products Reference file
GoTo 2
End If
Exit For
Next
'If there is news products then we copy it in the file Products
Reference
Application.ScreenUpdating = True
Range(Cells(2, 5), Cells(numblastline,
5)).SpecialCells(xlCellTypeVisible).Copy
Windows("Products Reference.xls").Activate
Sheets("Products").Select
NumbLineProd = [a65536].End(xlUp).Row
Cells(NumbLineProd + 1, 1).Select: Selection.PasteSpecial xlValues
Windows(nameoffile).Activate
Range(Cells(2, 6), Cells(numblastline,
6)).SpecialCells(xlCellTypeVisible).Copy
Windows("Products Reference.xls").Activate
Cells(NumbLineProd + 1, 3).Select: Selection.PasteSpecial xlValues
Windows(nameoffile).Activate
Range(Cells(2, 9), Cells(numblastline,
9)).SpecialCells(xlCellTypeVisible).Copy
Windows("Products Reference.xls").Activate
Cells(NumbLineProd + 1, 2).Select: Selection.PasteSpecial xlValues
Windows(nameoffile).Activate
Range(Cells(2, ColumnType), Cells(numblastline,
ColumnType)).SpecialCells(xlCellTypeVisible).Copy
Cells(VarNewProduct.Row, 1).Select
Windows("Products Reference.xls").Activate
Cells(NumbLineProd + 1, 7).Select: Selection.PasteSpecial xlValues
If [a65536].End(xlUp).Row - NumbLineProd > 1 Then
r2 = r3 = 0
tablProd = Range(Cells(NumbLineProd + 1, 1),
Cells([a65536].End(xlUp).Row, 1)).Value
For r = 2 To [a65536].End(xlUp).Row - NumbLineProd
For r1 = 1 To r - 1
r2 = 0
If tablProd(r, 1) = tablProd(r1, 1) Then
r2 = 1
Exit For
End If
Next r1
If r2 = 1 Then
Cells(NumbLineProd + r - r3, 1).EntireRow.Delete
r3 = r3 + 1
End If
Next r
End If
Cells(NumbLineProd + 1, 1).Select
Windows(nameoffile).Activate
Sheets("data").Select
On Error Resume Next
ActiveSheet.Protection.AllowEditRanges(1).Delete
ActiveSheet.Protection.AllowEditRanges(1).Delete
ActiveSheet.Protection.AllowEditRanges.Add Title:="Range2", Range:= _
Range("A2", [BC65536].End(xlUp)).SpecialCells(xlCellTypeVisible)
ProtectionMartin (numblastline)
Sheets("pivot").Select
ActiveSheet.PivotTables("PivotTable2").PivotCache.Refresh
Sheets("Manual adjustement pivot").Select
ActiveSheet.PivotTables("PivotTable3").PivotCache.Refresh
Sheets("data").Select
Exit Sub
2
'If Procuts file was close at start, we reclose it
If NumbFileOpen = 2 Then
Workbooks("Products Reference.xls").Save
Windows("Products Reference.xls").Close
Windows(nameoffile).Activate
End If
ProtectionMartin (numblastline)
Application.ScreenUpdating = True
[A2].Select
Sheets("pivot").Select
ActiveSheet.PivotTables("PivotTable2").PivotCache.Refresh
Sheets("Manual adjustement pivot").Select
ActiveSheet.PivotTables("PivotTable3").PivotCache.Refresh
Sheets("data").Select
Exit Sub
3
MsgBox ("The adress of the file of the Products Reference is not good."
_
& "Please look at it before launching the macro again.")
4
Msg = "Error # " & Str(Err.Number) & " was generated by " _
& Err.Source & Chr(13) & Err.Description
MsgBox Msg, , "Error"
End Sub
autofilter :
Option Explicit
Sub FiltreMartin(bmode As Boolean)
If ActiveSheet.AutoFilterMode Then
'Autofilter is on
If Not bmode Then
'wants to turn it off... but warning if filter active, lines would
be hidden
Rows("1:1").Select
On Error Resume Next
ActiveSheet.ShowAllData
Selection.AutoFilter
End If
Else
'Autofilter is off
If bmode Then
'Turn is on
Rows("1:1").Select
Selection.AutoFilter
End If
End If
End Sub
FIll fnubs and type :
Public Const ColumnFnubs = 22
Public Const ColumnType = 10
Sub FillFnubsAndTypeMartin(numblastline As Long)
Application.Calculation = xlManual
Application.ScreenUpdating = False
Sheets("data").Select
ActiveSheet.Unprotect ("qsdfgh")
'Replace FNUBS by Formula
Cells(2, ColumnFnubs).FormulaR1C1 > "=IF(RC[-11]=""PC"",RC[-1],IF(RC[-11]=""TC"",RC[-1],IF(RC[-11]=""AV
PC"",RC[-1],if(RC[-11]=""ALC PC"",RC[-1],0))))"
Cells(2, ColumnFnubs).AutoFill Destination:=Range(Cells(2,
ColumnFnubs), _
Cells(numblastline, ColumnFnubs))
Cells(2, ColumnFnubs + 1).FormulaR1C1 > "=IF(RC[-12]=""Monitor"",RC[-2],0)"
Cells(2, ColumnFnubs + 1).AutoFill Destination:=Range(Cells(2,
ColumnFnubs + 1), _
Cells(numblastline, ColumnFnubs + 1))
'Research in Products Reference File of the Extended Type
'and Simplified Family of each poduct
Cells(2, ColumnType + 1).FormulaR1C1 = _
"=VLOOKUP(RC[-6],'[Products Reference.xls]Products'!C1:C6,4,FALSE)"
Cells(2, ColumnType + 2).FormulaR1C1 = _
"=VLOOKUP(RC[-7],'[Products Reference.xls]Products'!C1:C6,5,FALSE)"
Cells(2, ColumnType + 3).FormulaR1C1 = _
"=VLOOKUP(RC[-8],'[Products Reference.xls]Products'!C1:C6,6,FALSE)"
Range(Cells(2, ColumnType + 1), Cells(2, ColumnType + 3)).AutoFill _
Destination:=Range(Cells(2, ColumnType + 1), Cells(numblastline,
ColumnType + 3))
End Sub
Protcetion :
Sub ProtectionMartin(numblastline As Double)
On Error Resume Next
ActiveSheet.Protection.AllowEditRanges.Add Title:="Range1", Range:= _
Range(Cells(numblastline, 1), Cells(numblastline + 1000, 256))
ActiveSheet.Protect DrawingObjects:=True, Contents:=True, Scenarios:=True
_
, AllowSorting:=True, AllowFiltering:=True,
AllowUsingPivotTables:=True,
Password:="qsdfgh"
End Sub
Userform :
Private Sub UserForm_Activate()
Dim n, q, p As Integer
Dim VarNewProduct As Variant
Windows("new mec martin.xls").Activate
Sheets("data").Select
Application.Calculation = xlManual
Application.ScreenUpdating = False
ActiveSheet.Unprotect ("qsdfgh")
FiltreMartin ("true")
Selection.AutoFilter field:, Criteria1:="<>"
n = 1
p = 0
For Each VarNewProduct In Range("O2",
[O65536].End(xlUp)).SpecialCells(xlCellTypeVisible)
If VarNewProduct.Value <> "" And VarNewProduct.Value <> "Manual Label"
Then
If n <> 1 Then
For q = 1 To n - 1
If VarNewProduct.Value = Controls("checkbox" & q).Caption
Then
GoTo 1
End If
Next
End If
Controls("checkbox" & n).Caption = VarNewProduct.Value
Controls("checkbox" & n).Visible = True
n = n + 1
p = 1
End If
1
Next
If p = 0 Then
Unload Me
MsgBox ("There is no Manual correction !")
Sheets("control").Select
Range("e47").Value = [sum(data!AK:Ak)] - [sumif(data!b:b;"hp
europe";ak:ak)]
Range("e48").Value = [sum(data!AY:AY)] - [sumif(data!b:b;"hp
europe";ay:ay)]
Range("f20:f21").Calculate
Sheets("data").Select
ActiveSheet.ShowAllData
Cells(2, 34).FormulaR1C1 = "=control!R20C6*RC[1]"
Cells(2, 34).AutoFill Destination:=Range(Cells(2, 34),
[AH65536].End(xlUp))
Cells(2, 46).FormulaR1C1 = "=control!R21C6*RC[1]"
Cells(2, 46).AutoFill Destination:=Range(Cells(2, 46),
[AT65536].End(xlUp))
Columns("ah:ah").Calculate
Columns("at:at").Calculate
Columns("aw:ay").Calculate
Sheets("control").Select
Selection.Calculate
Application.Calculation = xlAutomatic
Application.ScreenUpdating = True
ProtectionMartin ([a65536].End(xlUp).Row)
End If
If n > 2 Then
For r = 1 To n - 1
If r Mod 2 = 1 Then
Controls("checkbox" & r).Left = 24
Else
Controls("checkbox" & r).Left = 144
End If
Controls("checkbox" & r).Top = 72 + Round(r / 2 - 0.9, 0) * 30
Next
UserFormMartin.Height = 167 + 30 * Round(r / 2 - 0.9, 0)
Cb_ok.Top = 102 + Round(r / 2 - 0.9, 0) * 30
Cb_cancel2.Top = 102 + Round(r / 2 - 0.9, 0) * 30
End If
End Sub
Private Sub Cb_cancel_Click()
Unload Me
End Sub
Private Sub CB_ok_Click()
Dim dblsum, dblsumalnr, dblsumalcos As Double
Dim Ctrl As Variant
UserFormMartin.Hide
Sheets("data").Select
Cells(2, 36).FormulaR1C1 = "=control!R47C6*RC[1]"
Cells(2, 36).AutoFill Destination:=Range(Cells(2, 36),
[AJ65536].End(xlUp))
Cells(2, 50).FormulaR1C1 = "=control!R48C6*RC[1]"
Cells(2, 50).AutoFill Destination:=Range(Cells(2, 50),
[AX65536].End(xlUp))
FiltreMartin ("true")
Selection.AutoFilter field:, Criteria1:="<>"
Selection.AutoFilter field:=2, Criteria1:="<>HP Europe", Operator:=xlAnd
dblsumnr = dblsumcos = 0
For Each Ctrl In UserFormMartin.Controls
If TypeName(Ctrl) = "CheckBox" Then
If Ctrl.Value = True Then
For Each cell In Range("O2",
[O65536].End(xlUp)).SpecialCells(xlCellTypeVisible)
If cell.Value = Ctrl.Caption Then
dblsumnr = dblsumnr + cell.Offset(0, 22).Value
dblsumcos = dblsumcos + cell.Offset(0, 36).Value
cell.Offset(0, 21).Value = 0
cell.Offset(0, 35).Value = 0
End If
Next
End If
End If
Next
dblsumalnr = [sum(AK:Ak)] - dblsumnr - [sumif(b:b,"HP Europe",Ak:Ak)]
dblsumalcos = [sum(AY:AY)] - dblsumcos - [sumif(b:b,"HP Europe",Ay:Ay)]
Sheets("control").Select
Range("e47").Value = dblsumalnr
Range("e48").Value = dblsumalcos
Unload UserFormMartin
Sheets("data").Select
Columns("aj:aj").Calculate
Columns("ax:ax").Calculate
Columns("ba:bc").Calculate
Application.Calculation = xlAutomatic
Application.ScreenUpdating = True
ProtectionMartin ([a65536].End(xlUp).Row)
End Sub
