Macro ComPleXe Excel

Version imprimable

08/06/2010, 12h11
maxxxime

Macro ComPleXe Excel

Bonjour!

Alors j'ai une macro très compliqué à faire je sais même pas si je vais réussir à vous l'expliquer correctement:?.
Alors voila, il faut que j'inscrive dans une feuille excel(feuille 3) toutes les lignes contenus dans une autre feuille(feuille 1) où il y a à la fois dans la colonne A un chiffre commençant par 6 et dans la colonne G un chiffre supérieur à un autre chiffre indiqué dans une autre feuille(feuille 2) dans la cellule C3.

Voilà à vous les pros d'excel...
08/06/2010, 12h14
BenjGe

tu ne veux pas essayer de rédiger le début d'un code?

sinon voici un code (non testé) :

Code:

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
 
 
Sub Programme()
 
Set plage = thisworkbook.sheets(1).range(cells(1,1),cells(1,1).End(XlDown)
' >> ou bien :
' Set plage = thisworkbook.sheets(1).range(cells(1,1),cells(1,X)) où X est le 'numéro de la dernière ligne de la feuille 1 que tu vx analysé
 
ligne = 1
 
For each cellule in plage
 
if Left(cellule.value,1) = 6 and cellule.offset(0,6).value > sheets(2).range("C3").value then
sheets(3).rows(cellule.row).copy Destination:=cells(ligne,1)
ligne = ligne + 1
end if
 
End sub

Merci sympasteve parce que j'arrivais pas à trouver.

Sinon la macro bloque

Voilà ce que ça donne:

Code:

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
Sub Extraction()
 
Set plage = thisworkbook.sheets(1).range(cells(1,1),cells(1,1).End(XlDown)
 
ligne = 1
 
For Each cellule In plage
 
If Left(cellule.Value, 1) = 6 And cellule.Offset(0, 6).Value > Sheets(2).Range("C3").Value Then
Sheets(3).Rows(cellule.Row).Copy Destination:=Cells(ligne, 1)
ligne = ligne + 1
End If
Next
 
 
End Sub

Ca bloque au niveau du "set plage".
J'ai essayé avec l'autre méthode ça bloque aussi.

Je l'ai encore modifié sur quelque petit point:

Code:

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
Sub Extraction()
 
Set plage = ThisWorkbook.Sheets(1).Range(Cells(1, 1), Cells(1, 500).End(xlDown)).Select
 
ligne = 1
 
For Each cellule In plage
 
If Left(cellule.Value, 1) = 6 And cellule.Offset(0, 6).Value > Sheets(2).Range("C3").Value Then
Sheets(3).Rows(cellule.Row).Copy Destination:=Cells(ligne, 1)
ligne = ligne + 1
End If
Next
 
 
'
End Sub

dans le même sens (en indiquant le nom de la feuille et non son index qui peut changer en fonction de l'emplacement des feuilles)

Code:

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
Dim i As Long, LastLig As Long, NewLig As Long
Dim Crit As Double
 
Application.ScreenUpdating = False
Crit = Sheets("Feuil2").Range("C3").Value
NewLig = Sheets("Feuil3").Cells(Rows.Count, 1).End(xlUp).Row + 1
With Sheets("Feuil1")
    LastLig = .Cells(Rows.Count, 1).End(xlUp).Row
    For i = 2 To LastLig
        If Left(.Range("A" & i).Value, 1) = 6 And .Range("G" & i).Value >= Crit Then
            .Rows(i).Copy Sheets("Feuil3").Range("A" & NewLig)
            NewLig = NewLig + 1
        End If
    Next i
End With

09/06/2010, 09h55
maxxxime

Ok c'est bon elle marche.

Merci beaucoup!
29/06/2010, 11h55
maxxxime

Bonjour,

Je voudrais relancer ce sujet car mon tableau a changé.

Alors en fait maintenant dans la colonne A, où j'ai mes cellules commençant par "7" j'ai aussi des cellules avec uniquement le chiffre "7".Celle là je ne souhaiterais pas les reprendre.

J'ai essayé en changeant le critère 7 dans la macro par le critère "7*" mais cela ne marche pas...

Quelqu'un aurait-il une solution?

Merci d'avance
29/06/2010, 12h07
zyhack

Bonjour

tu peux remplacer

Code:

If Left(.Range("A" & i).Value, 1) = 6 And .Range("G" & i).Value >= Crit Then

par

Code:

If .Range("A" & i).Value Like "7?*" = True And .Range("G" & i).Value >= Crit Then
29/06/2010, 14h03
maxxxime

Ok merci ça marche nikél

Mais du coup j'aperçois qu'il y a des chiffres à 2 nombres que je ne veux pas extraire...

Comment faire pour par exemple extraire uniquement les chiffres commençant par 75 ou 73 par exemple
Il doit y avoir une formule ou comme dans excel.

Ou plus simple, avoir uniquement les comptes différents de du chiffre "60", différent du chiffre "61", ça allégera un peu plus la macro parce que il y a pas mal de nombre à extraire
29/06/2010, 14h45
zyhack

bonjour

pour 75 ou 73

Code:

If .Range("A" & i).Value like "[73,75]*" = True And .Range("G" & i).Value >= Crit Then

Voila ma macro:

Code:

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
Sub ExtraireProduits()
'
' ExtraireProduits Macro
'
Dim i As Long, LastLig As Long, NewLig As Long
Dim Crit As Double
 
Application.ScreenUpdating = False
Crit = Sheets("Feuil2").Range("C8").Value
NewLig = Sheets("Feuil4").Cells(Rows.Count, 1).End(xlUp).Row + 1
With Sheets("Feuil1")
    LastLig = .Cells(Rows.Count, 1).End(xlUp).Row
    For i = 2 To LastLig
       If .Range("A" & i).Value Like "[73,75]*" = True And .Range("K" & i).Value >= Crit Then
            .Rows(i).Copy Sheets("Feuil4").Range("A" & NewLig)
            NewLig = NewLig + 1
        End If
    Next i
End With
'
End Sub

L'extraction prend toutes les lignes et non seulement ceux commençant par 73 et 75

bonjour

La seul solution que j'ai trouvé ce fait en deux étapes (précisions en commentaire)

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
 
Sub ExtraireProduits()
'
' ExtraireProduits Macro
'
Dim i As Long, LastLig As Long, NewLig As Long
Dim Crit As Double
 
Application.ScreenUpdating = False
Crit = Sheets("Feuil2").Range("C8").Value
NewLig = Sheets("Feuil4").Cells(Rows.Count, 1).End(xlUp).Row + 1
With Sheets("Feuil1")
    LastLig = .Cells(Rows.Count, 1).End(xlUp).Row
    For i = 2 To LastLig
       '1er étape vérifier qu'il y ai au moins 2 caractères
       'dont le premier commençant par 7 avec like
       If .Range("A" & i).Value Like "7?*" = True And .Range("K" & i).Value >= Crit Then
          '2eme étape vérifier que les deux premier chiffres sont présent
          'dans la chaine "75 73" avec instr
          If InStr(1, "75 73", .Left(Range("A" & i).Value), 2) > 0 Then
            .Rows(i).Copy Sheets("Feuil4").Range("A" & NewLig)
            NewLig = NewLig + 1
          End If
        End If
    Next i
End With
'
End Sub

30/06/2010, 10h06
maxxxime

Instr bogue...
30/06/2010, 11h17
maxxxime

En fait je préférerais avoir uniquement les valeurs différentes de "7" "75" "76". Sachant que les autres valeurs peuvent commencer par 7, par 75 et par 76 et qu'il contienne 8 chiffres

Bonjour

Citation:

et qu'il contienne 8 chiffres

S'il doivent contenir 8 chiffres, obligatoirement 7, 75 et 73 seront éliminés donc simplement en vérifiant la longueur tu obtiendra le résultat escompté.

Code:

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
 
Sub ExtraireProduits()
'
' ExtraireProduits Macro
'
Dim i As Long, LastLig As Long, NewLig As Long
Dim Crit As Double
 
Application.ScreenUpdating = False
Crit = Sheets("Feuil2").Range("C8").Value
NewLig = Sheets("Feuil4").Cells(Rows.Count, 1).End(xlUp).Row + 1
With Sheets("Feuil1")
    LastLig = .Cells(Rows.Count, 1).End(xlUp).Row
    For i = 2 To LastLig
       'Le 7 tous court n'est plus pris en compte
       If Len(.Range("A" & i).Value) = 8 Then
            .Rows(i).Copy Sheets("Feuil4").Range("A" & NewLig)
            NewLig = NewLig + 1
        End If
    Next i
End With
'
End Sub

30/06/2010, 13h18
maxxxime

Nikél ça marche merci beaucoup pour ton aide!