an@s
XLDnaute Occasionnel
Bonjour le forum,
je reviens vers vous à nouveau pour vous demander si c'est possible de modifier le code ci-dessous fourni par job pour conserver les couleurs après importation
Merci d'avance
Amicalement
Ana@s
je reviens vers vous à nouveau pour vous demander si c'est possible de modifier le code ci-dessous fourni par job pour conserver les couleurs après importation
VB:
Private Sub CommandButton1_Click()
Dim ncol%, nlig&, t, nlig1&, P As Range, d As Object, i&, P1 As Range, x$, j&
ncol = 45 'nombre de colonnes du tableau, adaptable
Application.ScreenUpdating = False
With Workbooks.Open(ThisWorkbook.Path & "\Matrice.xlsx").Sheets("MNT")
nlig = .Range("C" & .Rows.Count).End(xlUp).Row
If nlig > 1 Then nlig = nlig - 1
.[E2].Resize(nlig) = "=RC[4]-RC[7]-(RC[40]+RC[31]+RC[18])"
.[M2].Resize(nlig) = "=RC[-4]-RC[-1]"
.[N2].Resize(nlig) = "=RC[-2]+(RC[9]+RC[22]+RC[31])"
.[O2].Resize(nlig) = "=IFERROR(RC[-3]/RC[-1],"""")"
.[W2].Resize(nlig) = "=SUM(RC[-5]:RC[-1])"
.[AJ2].Resize(nlig) = "=SUM(RC[-12]:RC[-1])"
.[AS2].Resize(nlig) = "=SUM(RC[-8]:RC[-1])"
t = .[A2].Resize(nlig, ncol).FormulaR1C1
.Parent.Close False
End With
'---restitution des valeurs et formules du 1er tableau---
nlig1 = Range("C" & Rows.Count).End(xlUp).Row + 2
With [A3].Resize(nlig1, ncol)
.Borders.LineStyle = xlNone 'supprime les bordures
.Copy [A3].Offset(, ncol) 'sauvegarde TOUT le tableau vers la droite
.Delete xlUp 'RAZ
End With
Set P = [A3].Resize(nlig, ncol)
P = t
'---liste des "Hiérarchie OTP" du 1er tableau (sans doublon)---
Set d = CreateObject("Scripting.Dictionary")
For i = 1 To nlig
If t(i, 3) <> "" Then d(t(i, 3)) = i 'repère la ligne
Next i
'---copie les lignes du 2ème tableau vers le 1er---
Set P1 = [A3].Offset(, ncol).Resize(nlig1, ncol)
For i = 1 To nlig1
x = P1(i, 3)
If x <> "" And d.Exists(x) Then
j = d(x)
P(j, "E") = P1(i, "E").FormulaR1C1
P(j, "M") = P1(i, "M").FormulaR1C1
P(j, "N") = P1(i, "N").FormulaR1C1
P(j, "O") = P1(i, "O").FormulaR1C1
P(j, "W") = P1(i, "W").FormulaR1C1
P(j, "AJ") = P1(i, "AJ").FormulaR1C1
P(j, "AS") = P1(i, "AS").FormulaR1C1
P1.Rows(i).Copy
P(j, 1).PasteSpecial xlPasteFormats 'copie les couleurs
End If
Next i
P1.EntireColumn.Delete 'RAZ
'---bordures---
P.Borders(xlEdgeLeft).Weight = xlThin
P.Borders(xlEdgeTop).Weight = xlThin
P.Borders(xlEdgeRight).Weight = xlThin
P.Borders(xlEdgeBottom).Weight = xlMedium 'pourquoi pas...
P.Borders(xlInsideVertical).Weight = xlThin
P.Borders(xlInsideHorizontal).Weight = xlHairline
'---actualise les barres de défilement---
With Me.UsedRange: End With
[A1].Select
End Sub
Merci d'avance
Amicalement
Ana@s