Copier cellule selon son contenu

**jérémyp8** · 21/05/2013, 11h34

Bonjour à tous,

Ma toute dernière étape consiste à copier les données de chaque projet de mon fichier Excel que vous trouverez en pièce jointe dans un autre nouveau classeur Excel vide qui aura deux Feuilles calcul qui s’appelleront :«Obsolescence» et « Greenwich » comme suit :

Pour chaque projet :
Si y’a au moins une ligne rouge sur l’une de ses version OS ou SGBD On copie toutes les données de ce projet dans la feuille de mon nouveau fichier Excel qui est Greenwich

Si toutes les versions des OS et SGBD sont sans couleur rouge On copie toutes les données de ce projet dans la feuille de calcul de mon nouveau fichier Excel qui est Obsolescence

Remarque :
Quand je dis toutes les données de chaque projet = c'est chaque :
Nom Projet, OS, Version OS, SGSBD, Version SGBD, WAS, Version WAS séparé entre deux lignes vides dans le fichier Excel

Ces lignes rouge sont générées grâce a une macro dans le module 3 qui fait le test sur les cellules OS et GSBD comme suit :
On colorie les cellules OS et SGBD qui différentes des version posées dans le code
Celles qui sont égales aux versions présentent dans le test (macro) on les colore pas

Merci pour votre aide

**Daniel.C** · 21/05/2013, 12h59

Bonjour,

Macro à mettre dans le classeur "Macro1.xlsm" :

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

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
Sub Export()
    Dim Ligne As Long, Plage As Range, Ligne1 As Long, Ligne2 As Long
    Dim Wbk As Workbook, Sh1 As Worksheet, Sh2 As Worksheet, C As Range
    Dim NomProjet As String
    With ThisWorkbook.Sheets("Feuil1")
        Ligne = .Cells.Find("*", , , , xlByRows, xlPrevious).Row
        Set Plage = .Range(.[A4], .Cells(Ligne, 1))
        Ligne1 = 1
        Ligne2 = 1
    End With
    Set Wbk = Workbooks("Mon Nouveau Fichier.xlsm")
    Set Sh1 = Wbk.Sheets("Elements d'obsolescence ")
    Set Sh2 = Wbk.Sheets("Elements Greenwich")
    For Each C In Plage
        If Application.CountIf(C.Resize(, 7), "") < 7 Then
            If C.Value <> "" Then NomProjet = C.Value
            If C.Offset(, 2).Interior.ColorIndex = 3 Or _
                C.Offset(, 4).Interior.ColorIndex = 3 Then
                Ligne2 = Ligne2 + 3
                Sh2.Cells(Ligne2, 1) = NomProjet
                Sh2.Cells(Ligne2, 2).Resize(, 6).Value = C.Offset(, 1).Resize(, 6).Value
            Else
                Ligne1 = Ligne1 + 3
                Sh1.Cells(Ligne1, 1) = NomProjet
                Sh1.Cells(Ligne1, 2).Resize(, 6).Value = C.Offset(, 1).Resize(, 6).Value
            End If
        End If
    Next C
End Sub

**jérémyp8** · 21/05/2013, 14h22

Bonojour Daniel.C,

Merci pour ta réponse

Quand je lance ta macro j'ai l'erreur 9 l'indice n'appartient pas à la sélection sur la ligne 11

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

    Set Wbk = Workbooks("Mon Nouveau Fichier.xlsm")

Je suis en train d'essayer de la résoudre mais je y arrive pas

Schant que le classeur "Macro1.xlsm" dans lequel je met cette macro se trouve dans le meme dossier que mon nouveau fichier Excel !

Merci

**Daniel.C** · 21/05/2013, 14h34

C'est l'un des deux classeurs zippés. Il doit être ouvert.

**jérémyp8** · 21/05/2013, 15h14

Re Daniel.C

Ta macro marche bien

En effet avant de lancer la macro il faut d'abord ouvrir le Nouveau fichier Excel dans lequel on va copier les donnée

Cette macro fait prèsque ce que je veux c'est-à-dire elle copie les lignes en rouge dans Greenwich et les lignes non colorées en rouge dans obsolescence

Mais moi ce je veux que la macro fasse c'est de copier Non Projet, OS, Version OS, SGBD, Version SGBD, WAS, Version Was qui sont ENTRE DEUX LIGNES VIDES si ya au moins une des ligne Version SGBD/OS est en rouge

Exemple : pour cahque nom du projet (séparé entre deux lignes completement vides) qui comme lignes 10, 11, 12 dans mon fichier Excel Macro1.Xmls j'ai ces données:

Non Projet | OS | VOS | SGBD | VSGBD | WAS | VWAS

DAT-G1R5.doc | AIX virtualisé v5.3 | RMAN | 10gR2 | Tomcat 5.5.20

..................... Linux RH4.0 32 bits | Oracle |10gR2 | Tomcat |5.5.17

......................Windows | 2008 R2 | MySQL | 5.0.34

Je remarque que y'a au moins une ligne rouge sur Version OS ou SGBD Donc je copie le toutes ces lignes rouge et aussi pas rouges ( toutes les colonnes de mon projet ) dans la feuille de calcul Obsolescence de mon nouveau fichier Excel

J'espère que tu as compris ce que je veux faire

Merci

**Daniel.C** · 21/05/2013, 15h54

Rien compris.

Pour chaque projet :
Si y’a au moins une ligne rouge sur l’une de ses version OS ou SGBD On copie toutes les données de ce projet dans la feuille de mon nouveau fichier Excel qui est Greenwich

Pourquoi tu me donnes un exemple à copier dans "obsolescence" ? alors que plusieurs versions OS et SGBD sont rouges ?

**jérémyp8** · 21/05/2013, 16h22

Re

Je vais essayer de bien mexpliquer avec un Exemple

Tu trouveras en pièce jointe le classeur "Macro 1.xlsm" qui contient la macro ainsi que le résultat souhaité a avoir dans le classeur "Mon Nouveau Fichier.xlsm" apres l'excution de la macro

Merci

**Daniel.C** · 21/05/2013, 18h12

C'est mon dernier essai pour ce soir; j'espère que c'est bon...

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

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
Sub Export()
    Dim Ligne As Long, Plage As Range
 
    Dim Wbk As Workbook, Sh1 As Worksheet, Sh2 As Worksheet, C As Range
 
    Dim Res As Long, Teste As Boolean
 
 
    '''''AppExcel.Run "NomClasseur.xls!Message"
 
    With ThisWorkbook.Sheets("Feuil1")
        Ligne = .Cells.Find("*", , , , xlByRows, xlPrevious).Row
        Set Plage = .Range(.[A4], .Cells(Ligne, 1))
        'Set AppExcel = New Excel.Application
 
        'AppExcel.Visible = True
 
        'AppExcel.Workbooks.Open "C:\Chemin\NomClasseur.xls"
 
        Set Wbk = Workbooks("Mon Nouveau Fichier.xlsm")
        Set Sh1 = Wbk.Sheets("Elements d'obsolescence  ")
        Set Sh2 = Wbk.Sheets("Elements Greenwich ")
        For Each C In Plage
            If C.Row = 24 Then Stop
            If C.Value <> "" Then Res = C.Row
            If C.Offset(, 2).Interior.ColorIndex = 3 Or _
                C.Offset(, 4).Interior.ColorIndex = 3 Then
                Teste = True
            End If
 
            If (Application.CountIf(C.Resize(, 7), "") = 7 And Res > 0) Or C.Row = Plage.Rows.Count + 3 Then
                If Teste = True Then
                    Ligne = Sh1.Cells(Sh1.Rows.Count, 2).End(xlUp).Offset(2).Row
                    .Range(.Cells(Res, 1), C).Resize(, 7).Copy Sh1.Cells(Ligne, 1)
                Else
                    Ligne = Sh2.Cells(Sh2.Rows.Count, 2).End(xlUp).Offset(2).Row
                    .Range(.Cells(Res, 1), C).Resize(, 7).Copy Sh2.Cells(Ligne, 1)
                End If
                Teste = False
            End If
        Next C
    End With
End Sub