Excel VBA copier cellules avec formules

r4944 Messages postés 136 Statut Membre -  
r4944 Messages postés 136 Statut Membre -
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 



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.
A voir également:

1 réponse

Réponse 1 / 1
jordane45 Messages postés 40050 Date d'inscription   Statut Modérateur Dernière intervention   4 758
 
Bonjour,

Essayes de mettre .formulaLocal
A la ligne : 
Tablo(Cptr, Col) = .Cells(Lig, Col)


Comme ceci : 
Tablo(Cptr, Col) = .Cells(Lig, Col).formulalocal




Cordialement, 
Jordane                                                                 
1
r4944 Messages postés 136 Statut Membre
 
Merci Beaucoup Jordane :) , mais ça copie pas pour les mises en formes conditionnelles

exemple : de mettre en évidence des cellules qui manquent des données (en orange), des cellules qui ne requirent pas de données (en noir),
0
jordane45 Messages postés 40050 Date d'inscription   Statut Modérateur Dernière intervention   4 758 > r4944 Messages postés 136 Statut Membre
 
Ah ben non...
Ca copie le CONTENU de la cellule.
Pour copier les MFC ... tu ne peux pas utiliser ce code ...
0
r4944 Messages postés 136 Statut Membre
 
Voici ce que j'ai essayé de faire 


Tablo(Cptr, Col) = .Cells(Lig, Col).FormulaLocal.FormatCoditions
0
jordane45 Messages postés 40050 Date d'inscription   Statut Modérateur Dernière intervention   4 758 > r4944 Messages postés 136 Statut Membre
 
FormatCoditions 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...
0
r4944 Messages postés 136 Statut Membre
 
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
0

Discussions similaires

dessin avec symbole clavier
JSS -
Adraen -

79 réponses