Excel VBA copier cellules avec formules
Bonjour,
J'ai une macro qui me permet d'importer des donnees d'une feuille Excel vers la feuille active (qui contienne la macro) , le problème c'est que j'ai réussi à faire seulement le transfert des donnees », mias les formules ne sont pas importées ce qui pose un problème parce que nous devons souvent modifier les données après. Sans les formules, nous devons faire les calculs manuellement ce qui laisse place à des erreurs.
voici mon code
J'ai une macro qui me permet d'importer des donnees d'une feuille Excel vers la feuille active (qui contienne la macro) , le problème c'est que j'ai réussi à faire seulement le transfert des donnees », mias les formules ne sont pas importées ce qui pose un problème parce que nous devons souvent modifier les données après. Sans les formules, nous devons faire les calculs manuellement ce qui laisse place à des erreurs.
voici mon code
Option Explicit
Option Base 1
'--------
Sub Importdatav2()
Dim Source As Workbook, Dercol As Integer
Dim Nbre As Integer, Tablo, Cptr As Integer, derlig As Integer, Lig As Integer, Col As Integer
Dim FichiersAOuvrir, I As Integer
Application.ScreenUpdating = False
FichiersAOuvrir = Application.GetOpenFilename(, , , , True)
If IsArray(FichiersAOuvrir) Then
For I = LBound(FichiersAOuvrir, 1) To UBound(FichiersAOuvrir, 1)
Set Source = Application.Workbooks.Open(FichiersAOuvrir(I), , True)
With Sheets("Workload - Charge de travail")
Dercol = Cells(2, Columns.Count).End(xlToLeft).Column
Nbre = Application.CountIf(.Columns("AQ"), "XX")
ReDim Tablo(Nbre, Dercol)
Lig = 1
For Cptr = 1 To Nbre
Lig = .Columns("AQ").Find("XX", .Cells(Lig, "AQ"), xlValues).Row
For Col = 1 To Dercol
Tablo(Cptr, Col) = .Cells(Lig, Col)
Next Col
Next Cptr
End With
Source.Close False
With ThisWorkbook.Sheets("Sheet1")
derlig = .Range("A" & Rows.Count).End(xlUp).Row + 1 'premiere cellules vide colonne A
.Range("A" & derlig).Resize(Cptr, Dercol) = Tablo
'.Activate
End With
Next I
Else
MsgBox "Aucun choix"
End If
End Sub
| EDIT : Ajout des balises de code (la coloration syntaxique).
Explications disponibles ici : ICI Merci d'y penser dans tes prochains messages. |
1 réponse
-
ModérateurBonjour,
Essayes de mettre .formulaLocal
A la ligne :Tablo(Cptr, Col) = .Cells(Lig, Col)
Comme ceci :Tablo(Cptr, Col) = .Cells(Lig, Col).formulalocal
Cordialement,
Jordane-
-
Modérateur@r4944Ah ben non...
Ca copie le CONTENU de la cellule.
Pour copier les MFC ... tu ne peux pas utiliser ce code ... -
-
Modérateur@r4944FormatCoditions est une méthode de RANGE ... pas de FORMULALOCAL
https://docs.microsoft.com/fr-fr/office/vba/api/excel.formatcondition?redirectedfrom=MSDN
Il te faut récupérer les deux informations (la valeur/formule et la MFC ...) séparément... -
Re , ça devrait fonctionner de cette façon
Option Explicit
Option Base 1
'--------
Sub Importdatav2()
Dim Source As Workbook, Dercol As Integer
Dim Nbre As Integer, Tablo, Cptr As Integer, derlig As Integer, Lig As Integer, Col As Integer
Dim FichiersAOuvrir, I As Integer
Application.ScreenUpdating = False
FichiersAOuvrir = Application.GetOpenFilename(, , , , True)
If IsArray(FichiersAOuvrir) Then
For I = LBound(FichiersAOuvrir, 1) To UBound(FichiersAOuvrir, 1)
Set Source = Application.Workbooks.Open(FichiersAOuvrir(I), , True)
With Sheets("Workload - Charge de travail")
Dercol = Cells(2, Columns.Count).End(xlToLeft).Column
Nbre = Application.CountIf(.Columns("AQ"), "XX")
ReDim Tablo(Nbre, Dercol)
Lig = 1
For Cptr = 1 To Nbre
Lig = .Columns("AQ").Find("XX", .Cells(Lig, "AQ"), xlValues).Row
For Col = 1 To Dercol
With FichiersAOuvrir.Range("A:AP").FormatConditions(1)
With .Borders
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = 6
End With
With .Font
.Bold = True
.ColorIndex = 3
End With
End With
Tablo(Cptr, Col) = .Cells(Lig, Col).FormulaLocal
Next Col
Next Cptr
End With
Source.Close False
With ThisWorkbook.Sheets("Sheet1")
derlig = .Range("A" & Rows.Count).End(xlUp).Row + 1 'premiere cellules vide colonne A
.Range("A" & derlig).Resize(Cptr, Dercol) = Tablo
'.Activate
End With
Next I
Else
MsgBox "Aucun choix"
End If
End Sub
-
