1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117
| Sub AjBnc()
Dim i As Long, j As Long, k As Long, l As Long, m As Long, n As Long
Dim Trouve As Boolean
Dim Wb As Workbook
Dim Ws As Worksheet
For Each Wb In Application.Workbooks
If Wb.Name Like "Suivi bnc*" Then
Trouve = True
Exit For
End If
Next Wb
If Trouve Then
Set Ws = Wb.Worksheets(1)
i = Ws.Cells(Ws.Rows.Count, 1).End(xlUp).Row
Application.ScreenUpdating = False
With Ws
.Rows("1:2").Delete
.Range("A2:A" & i).SpecialCells(xlCellTypeBlanks).EntireRow.Delete
.Rows(Range("B65536").End(xlUp).Row).Delete
.Range("A2:A" & i).SpecialCells(xlCellTypeBlanks).EntireRow.Delete
.Columns("D").Copy
.Columns("J").PasteSpecial xlPasteValues
.Columns("A:B").Copy
.Columns("F:G").PasteSpecial xlPasteValues
.Range("L:N,E:E,B:B").Delete
.Range("A2:A" & i).Replace What:="*", Replacement:="BNC", LookAt:=xlWhole
.Range("G2:G" & i).Replace What:="*", Replacement:="", LookAt:=xlWhole
.Range("J2:J" & i).Replace What:="*", Replacement:=0, LookAt:=xlWhole
l = Ws.Cells(Ws.Rows.Count, 1).End(xlUp).Row
.Range("K2:K" & l).Formula = "=SUMIFS($I:$I,$D:$D,D2,$H:$H,2)"
.Columns("K").Copy
.Columns("K").PasteSpecial xlPasteValues
.Columns("A:J").Copy
.Columns("L").PasteSpecial xlPasteValues
.Range("V2:V" & l).Formula = "=SUMIFS($I:$I,$D:$D,D2,$H:$H,3)"
.Columns("V").Copy
.Columns("V").PasteSpecial xlPasteValues
.Range("G2:G" & l).Replace What:="*", Replacement:="Manquant", LookAt:=xlWhole
.Range("H2:H" & l).Replace What:="*", Replacement:=2, LookAt:=xlWhole
.Range("R2:R" & l).Replace What:="*", Replacement:="Inversion", LookAt:=xlWhole
.Range("S2:S" & l).Replace What:="*", Replacement:=3, LookAt:=xlWhole
.Range("E2:E" & l).SpecialCells(xlCellTypeBlanks).EntireRow.Delete
.Columns("K").Copy
.Columns("I").PasteSpecial xlPasteValues
.Range("I1").Value = "Nb de ligne de BNC"
.Columns("V").Copy
.Columns("T").PasteSpecial xlPasteValues
m = Ws.Cells(Ws.Rows.Count, 1).End(xlUp).Row
.Range("A" & m + 1 & ":J" & m + m - 1).Value = Range("L2:U" & m).Value
.Columns("K:V").Delete
.Range("I2:I" & m + m - 1).Replace What:=0, Replacement:="", LookAt:=xlWhole
.Range("I2:I" & m + m - 1).SpecialCells(xlCellTypeBlanks).EntireRow.Delete
n = Range("A" & Rows.Count).End(xlUp).Row
.Range("K2:K" & n).Formula = "=Month((B2))"
.Range("K2:K" & n).Copy
.Range("B2:B" & n).PasteSpecial xlPasteValues
.Columns("B").NumberFormat = "0"
.Columns("K").Delete
End With
k = Ws.Cells(Ws.Rows.Count, 1).End(xlUp).Row
With ThisWorkbook.Worksheets("MPH")
j = .Cells(.Rows.Count, 1).End(xlUp).Row
.Range("L" & j + 1).Formula = "=IFERROR(VLOOKUP(H" & j + 1 & ",BD!$A:$B,2,FALSE),0)"
.Range("M" & j + 1).Formula = "=IFERROR(I" & j + 1 & "/L" & j + 1 & ",0)"
.Range("K" & j + 1 & ":M" & j + 1).Copy
.Range("K" & j + 1 & ":M" & j + k - 1).PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _
False, Transpose:=False
.Range("A" & j + 1 & ":J" & j + 1 + k).Value = Ws.Range("A2:J" & k + 2).Value
.Range("N" & j + 1).Formula = "=IFERROR(INDEX($C$2:$D$" & j & ",MATCH(D" & j + 1 & ",$D$2:$D$" & j & ",0),1),0)"
.Range("N" & j + 1).Copy
.Range("N" & j + 1 & ":N" & j + k - 1).PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _
False, Transpose:=False
.Range("N" & j + 1 & ":N" & j + k - 1).Copy
.Range("C" & j + 1 & ":C" & j + k - 1).PasteSpecial xlPasteValues
.Range("N" & j + 1).Formula = "=IFERROR(VLOOKUP(D" & j + 1 & ",$D$2:$F$" & j & ",2,FALSE),"""")"
.Range("N" & j + 1).Copy
.Range("N" & j + 1 & ":N" & j + k - 1).PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _
False, Transpose:=False
.Range("N" & j + 1 & ":N" & j + k - 1).Copy
.Range("E" & j + 1 & ":E" & j + k - 1).PasteSpecial xlPasteValues
.Range("N" & j + 1).Formula = "=IFERROR(VLOOKUP(D" & j + 1 & ",$D$2:$F$" & j & ",3,FALSE),"""")"
.Range("N" & j + 1).Copy
.Range("N" & j + 1 & ":N" & j + k - 1).PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _
False, Transpose:=False
.Range("N" & j + 1 & ":N" & j + k - 1).Copy
.Range("F" & j + 1 & ":F" & j + k - 1).PasteSpecial xlPasteValues
.Range("N:N").Delete
End With
Application.ScreenUpdating = True
Else
MsgBox "L'importation des données que vous essayez d'effectuer ne peut être effectuée pour l'une des 4 raisons :" _
& vbCrLf & vbCrLf & "1 - Le fichier Suivi bncxxx n'est pas ouvert" & vbCrLf & _
"2 - Le fichier a un nom diffèrent de Suivi bncxxx" & vbCrLf & _
"3 - Le nom de la requête Infolog a été renommé dans ce cas modifier le nom dans la macro" & vbCrLf & _
"4 - Vous avez ouvert l'application Excel plusieurs fois - N'en ouvrir qu'une seule"
'Etape de Libération d'espace mémoire sur Ws et Wb
Set Ws = Nothing
Set Wb = Nothing
'Correspond au End If de If trouve
End If
End Sub |
Partager