[VBA EXCEL] - Importer une plage de valeur sans les formule et Mise en Forme Cellule

Version imprimable

18/10/2007, 19h16
ancel17

[VBA EXCEL] - Importer une plage de valeur sans les formule et Mise en Forme Cellule

Bonsoir à tous !

Je voudrais savoir comment faire pour n'importer que les valeurs d'une plage de données mais pas les formules puis appliquer une Mise en Forme Conditionnelle sur la colonne c dépendant si la valeur de la cellule(l,c) est différente de la valeur de la cellule(l,c-1).

Merci de vos contribution !

Bonsoir Ancel,
Pour le principe puisque tu ne dis rien de ton fichier, noms des feuilles, adresses des cellules...

Code:

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
    'Copie de la plage de données commençant en A1 et limitée aux
    premières ligne et colonne entièrement vides
    Worksheets("Feuil1").Range("A1").CurrentRegion.Copy
    'Collage des valeur et du format
    Sheets("Feuil4").Range("A1").PasteSpecial _
          Paste:=xlPasteValuesAndNumberFormats
 
    'suppression de la mise en forme conditionnelle... s'il en existe une
    Worksheets("feuil1").Range("D1").FormatConditions.Delete
    'Mise en forme conditionnelle sur la cellule D1 si C1 <>
    Worksheets("feuil1").Range("D1").FormatConditions.Add Type:=xlCellValue, _
        Operator:=xlNotEqual, Formula1:="=" & Range("D1").Offset(0, -1).Address
    'format de cellule désiré
    With Worksheets("feuil1").Range("D1").FormatConditions(1)
        With .Interior
            .ColorIndex = 28
        End With
    End With

Bonne soirée

18/10/2007, 22h44
ancel17

Merci Ouskel'n'or !

je teste ça demain, et si cela ne fonctionne pas, je donnerai plus de détails !

A+

Bonjour,

après teste, ça ne fonctionne pas terrible...
Code:

1 2 3 4 5 6 7 8 9 10 Set FL12 = CL1.Worksheets("Récapitulatif") Set FL22 = CL2.Worksheets("Récapitulatif") Set Plage = FL22.Range("F6:J11") FL22.Activate If Nom = "Laboratoire - Gammagraphie" Then FL12.Range("F60:F65").Clear FL12.Range("H60").UnMerge Plage.Copy FL12.Range("F60").PasteSpecial (xlPasteValues) End If
pour info la plage H60:J11 de Plage est fusionnée d'où le .UnMerge, mais je reste avec l'erreur suivante :

Citation:

Erreur d'exécution '1004' :

Cette opération requiert que les cellules fusionnées soient de taille identique.

Tu définis la plage que tu copies sur FL22... ok, mais tu appliques UnMerge à une seule cellule de FL12. tu es certain de n'avoir qu'une cellule fusionnée ?
Il est inutile d'instancier deux fois ta feuille

Code:

1
2
3
4
5
6
7
8
9
10
11
       Dim FL1 as worksheet
       Dim plage as range
            Set FL1 = CL1.Worksheets("Récapitulatif")
            Set Plage = FL1.Range("F6:J11")
            FL1.Activate
            If Nom = "Laboratoire - Gammagraphie" Then
                FL1.Range("F60:F65").Clear
                FL1.Plage.UnMerge
                FL1.Plage.Copy
                FL1.Range("F60").PasteSpecial (xlPasteValues)
            End If

Tu peux tester ?
A+

Salut !

le fait est que j'ai deux classeurs différents et donc deux feuilles différentes... Mais ce n'est plus ce problème qui m'amène, je l'ai résolu et voici le code utilisé :

Code:

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
Set CL1 = ThisWorkbook  'définition du classeur qui reçoit les données
Set FL11 = CL1.Worksheets("fonderie")
Set rep = fso.GetFolder(Application.ThisWorkbook.Path & "\Secteurs")
Set FL12 = CL1.Worksheets("Récapitulatif")
Set Plage1 = FL12.Range("F6:J65")
 
    With Plage1
        .Clear          'j'efface les données de la plage
        .UnMerge        'et retire défusionne les cellules qui le sont pour ne pas avoir de souci avec la dimension des cellules fusionnées !
    End With
 
    For Each secteur In rep.Files
        Wk = rep & "\" & secteur.Name
        If fso.GetExtensionName(Wk) = "xls" Then
            CL1.Save
            Set CL2 = Workbooks.Open(Wk)
            Nom = Left(secteur.Name, Len(secteur.Name) - 4)
 
            Set FL22 = CL2.Worksheets("Récapitulatif")  'définition de la feuille source des données (le classeur est définie avant dans une partie du code qui ne nous intéresse pas ici)
            Set Plage2 = FL22.Range("F6:J11")
 
            FL22.Activate
            FL22.Range("H6").UnMerge                    'je défusionne pour les même raisons que précédemment
            If Nom = "Bureaux" Then
                Plage2.Copy
                FL12.Range("F42").PasteSpecial (xlPasteValues)  'je colle où il faut
                FL12.Range("H42:J47").Merge             'je refusionne pour que ce soit beau
                FL12.Range("F42:J47").Borders(xlEdgeBottom).LineStyle = xlContinuous    'et je lui met des bordures
            ElseIf ...
                ...
            End If
            FL12.Range("H6:J65").WrapText = True    'renvoie automatique à la ligne, alignement des cellules
            FL12.Range("F6:G65").HorizontalAlignment = xlHAlignCenter
            FL12.Range("F6:J65").VerticalAlignment = xlVAlignCenter
            FL22.Range("H6:J11").Merge              'et refusion...
            FL22.Range("H6:J11").WrapText = True
 
            CL2.Close savechanges:=True
        End If
    Next
 
    With Plage1                                     'et rebordures et alignement
        .Borders(xlEdgeBottom).LineStyle = xlContinuous
        .Borders(xlEdgeBottom).Weight = xlMedium
        .Borders(xlEdgeRight).LineStyle = xlContinuous
        .Borders(xlEdgeRight).Weight = xlMedium
        .Borders(xlEdgeLeft).LineStyle = xlContinuous
        .Borders(xlEdgeTop).LineStyle = xlContinuous
        .Borders(xlEdgeTop).Weight = xlMedium
        .Borders(xlInsideVertical).LineStyle = xlContinuous
    End With
 
    For Each c2 In FL12.Range("G6:G65").Cells   'MFC
        If Not c2 = c2.Offset(0, -1) Then
            c2.Font.ColorIndex = 3
        End If
    Next

Mon problème à présent est le suivant :
j'ai un texte concaténé dans une cellule de la manière suivante :

Code:

FL11.Range("A" & premlig & ":" & "A" & derlig).Value = Nom & Chr(10) & Chr(10) & "Dernière mise à jour : " & FL21.Range("H1")

je voudrais que seule la partie "Dernière mise à jour : " & FL21.Range("H1") soit en "Normal Italic".
J'imagine qu'avec Characters() on doit s'en sortir, mais la longueur de mon texte total est variable et seule la longueur de la partie à mettre en "Normal Italic" est connue (34).

Une solution simple est basculé les deux parties pour avoir la partie "Normal Italic" devant, mais moi je la veux derrière...

19/10/2007, 16h14
AlainTech
Citation:

Envoyé par ouskel'n'or

Il est inutile d'instancier deux fois ta feuille

Tss, tss...
Encore lu trop vite?
Code:

1 2 Set FL12 = CL1.Worksheets("Récapitulatif") Set FL22 = CL2.Worksheets("Récapitulatif")

Salut Alain,
Et toi t'as pas tout lu ! :mouarf:
Citation:
Envoyé par ancel17 Aujourd'hui 08h40
Bonjour,

après teste, ça ne fonctionne pas terrible...
Code:

1 2 3 4 5 6 7 8 9 10 Set FL12 = CL1.Worksheets("Récapitulatif") Set FL22 = CL2.Worksheets("Récapitulatif") Set Plage = FL22.Range("F6:J11") FL22.Activate If Nom = "Laboratoire - Gammagraphie" Then FL12.Range("F60:F65").Clear FL12.Range("H60").UnMerge Plage.Copy FL12.Range("F60").PasteSpecial (xlPasteValues) End If
pour info la plage H60:J11 de Plage est fusionnée d'où le .UnMerge, mais je reste avec l'erreur suivante :
Tu en aurais déduit quoi ? ;)

21/10/2007, 15h03
AlainTech

Qu'il copie du classeur CL2 vers le classeur CL1 :mouarf:

Citation:

Envoyé par AlainTech

Qu'il copie du classeur CL2 vers le classeur CL1 :mouarf:

Y'a que ceux qui ne font rien qui ne risquent pas de se tromper ! :langue:

Hello ancel17,
Soyons constructifs, nous. Pour avoir la dernière partie, tu as vblf (chr(10)) comme repère
J'ai remplacé ta chaîne par la mienne mais le principe est le même
Code:

1 2 3 4 5 'Chaine = Nom & Chr(10) & Chr(10) & "Dernière mise à jour : " & FL21.Range("H1") Chaine = "Chose" & Chr(10) & Chr(10) & "Dernière mise à jour : " & "Un autre texte" Result = Mid(Chaine, InStr(Chaine, vbLf) + 2, Len(Chaine) - InStr(Chaine, vbLf) + 2) 'FL11.Range("A" & premlig & ":" & "A" & derlig).Value = Result MsgBox Result
Tu sauras adapter ?

22/10/2007, 11h29
ancel17

Bonjour Ouskel'n'or

Tout d'abord, merci de ton aide !

Passons à mon problème.
il me semble que Mid() s'applique à une chaine de caractère et pas à un objet Range.
Du coup, j'agit sur la chaine avant de l'envoyer dans la cellule, mais après la mise en forme reste celle de la cellule, et je ne peux pas avoir deux mise en forme différente dans la même cellule... mais je me trompe peut-être ?

Je t'ai donné principe pour trouver la fin de ta chaîne, pas pour que tu colles cette fin telle quelle.
Ensuite tu ne peux appliquer un format sur une partie de cellule pour une plage. La mise en forme ne peut se faire que cellule par cellule.

Code:

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
Sub test()
Dim Chaine$, PremLig%, DerLig%, Ch1$, ch2$, lch1%, lch2%
    PremLig = 1
    DerLig = 10
    'Chaine = Nom & Chr(10) & Chr(10) & "Dernière mise à jour : " & FL21.Range("H1")
    Chaine = "Chose" & Chr(10) & Chr(10) & "Dernière mise à jour : " & "Un autre texte"
    For Each Cell In Range("H" & PremLig & ":" & "H" & DerLig)
        Cell.Value = Chaine
        Ch1 = Left(Chaine, InStr(Chaine, vbLf) - 1)
        Lch1 = Len(Ch1)
        Ch2 = Mid(Chaine, InStr(Chaine, vbLf) + 2, Len(Chaine) - InStr(Chaine, vbLf) + 2)
        LCh2 = Len(Ch2)
        With Cell.Characters(Start:=Lch1 + 3, Length:=LCh2).Font
                .ColorIndex = 5
        End With
    Next
End Sub

Essaie de t'inspirer de ça.
A+

Mille excuses, j'ai omis de te remercier pour ta réponse que je n'ai d'ailleurs pas encore eu le temps de tester... :oops:

je me pose une question concernant le code que tu m'as donné pour la suppression des MFC :
Code:

1 2 'suppression de la mise en forme conditionnelle... s'il en existe une Worksheets("feuil1").Range("D1").FormatConditions.Delete
je l'utilise ici :
Code:

1 2 3 4 5 6 7 8 9 10 11 12 13 Private Sub Worksheet_Change(ByVal Target As Range) If Target.Address Like "$E$*" Then If Target.Value = "non" Then Worksheets("Suivi candidatures").Range(Cells(Target.Row, 4)).FormatConditions.Delete Range(Cells(Target.Row, 1), Cells(Target.Row, 5)).Font.ColorIndex = 3 ElseIf Target.Value = "oui" Then Worksheets("Suivi candidatures").Range(Cells(Target.Row, 4)).FormatConditions.Delete Range(Cells(Target.Row, 1), Cells(Target.Row, 5)).Font.ColorIndex = 10 Else Range(Cells(Target.Row, 1), Cells(Target.Row, 5)).Font.ColorIndex = 0 End If End If End Sub
Mais il me donne une erreur pointant sur la ligne de suppression MFC :

Citation:

Erreur d'exécution '1004':
Erreur définie par l'application ou par l'objet

Y a-t-il une librairie à ajouter dans les références ?

Bonjour, tu ne peux pas "intervenir" directement dans une autre feuille de cette façon. il faut précéder avec With :

Code:

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Column = 5 Then
  With Worksheets("Suivi candidatures")
    If Target.Value = "non" Then
         .Range(Cells(Target.Row, 4)).FormatConditions.Delete
         Range(Cells(Target.Row, 1), Cells(Target.Row, 5)).Font.ColorIndex = 3
    ElseIf Target.Value = "oui" Then
         .Range(Cells(Target.Row, 4)).FormatConditions.Delete
         Range(Cells(Target.Row, 1), Cells(Target.Row, 5)).Font.ColorIndex = 10
    Else
        Range(Cells(Target.Row, 1), Cells(Target.Row, 5)).Font.ColorIndex = 0
    End If
 End With
End If
End Sub

Non testé, mais c'est la façon de procéder sur une autre feuille à partir d'un évènement de feuille

26/10/2007, 11h24
ancel17

merci de ta réponse mapeh,

cependant je ne change pas de feuille vu que je n'en ai qu'une dans ce fichier.
le Worksheets("suivi candidatures") était là pour la lisibilité... Apparemment c'était pas une idée terrible :roll:
26/10/2007, 12h06
mapeh

Bonjour ancel,
dans ce cas, tu peux l'enlever.
le problème vient de ta façon de désigner la cellule :

Code:

Worksheets("Suivi candidatures").Range(Cells(Target.Row, 4))

remplace par :

Code:

Worksheets("Suivi candidatures").Cells(Target.Row, 4)
11/12/2013, 11h20
ancel17

Bonjour,

Vu la date du dernier post, j'imagine que j'avais dû résoudre le problème...
:oops: