[ RESOLU par des foreumeux.Merci ] Transferts des cellules impairs...

[Guido]

Bonsoir le Forum

J'aimerais transféré les cellules impair qui se trouvent dans la colonne de gauche,

dans la colonne de droite ,mais avec un code VBA.

Merci

Guido

 

[job75]

Bonsoir Guido,

Sub Impairs()
Dim P As Range, decal%
Set P = [K2:K19] 'plage à copier, à adapter
decal = 3 'décalage vers la droite, à adapter
With P.Offset(, decal)
  .FormulaR1C1 = "=IF(MOD(RC[" & -decal & "],2),RC[" & -decal & "],"""")"
  .Value = .Value
End With
End Sub

Sub Pairs()
Dim P As Range, decal%
Set P = [K2:K19] 'plage à copier, à adapter
decal = 3 'décalage vers la droite, à adapter
With P.Offset(, decal)
  .FormulaR1C1 = "=IF(NOT(MOD(RC[" & -decal & "],2)),RC[" & -decal & "],"""")"
  .Value = .Value
End With
End Sub

Fichier joint.

A+

 

[DoubleZero]

Bonjour, Guido, le Forum,

Comme ceci ?

Option Explicit
Sub Impair_transférer()
    Dim i As Long
    With Application: .ScreenUpdating = False: .Calculation = xlManual: .EnableEvents = False: End With
    Application.ScreenUpdating = False
    For i = Cells(Rows.Count, "k").End(xlUp).Row To 2 Step -1
        If Range("k" & i) Mod 2 <> 0 Then Range("k" & i).Offset(, 3) = Range("k" & i)
    Next
    Application.ScreenUpdating = True
    With Application: .EnableEvents = True: .Calculation = xlAutomatic: .ScreenUpdating = True: End With
End Sub

A bientôt

P. S. : Bonjour, job75

 

[Mytå]

Re le Forum

Il existe les Fonctions =Est.Pair() et =Est.Impair() sous Excel 2003 à condition
de cocher, dans Outils/Macros complémentaires, l'Utilitaire D'analyse.

Mytå

 

[Guido]

Bonsoir Job75,doublezero,Myta

Merci pour vos propositions

a plus

A piu tardi

Guido

Pour Myta peut tu recevoir le e mails...

Et ta santé ????

Amitiés

Guido

 

[Mytå]

Re

Oui Guido, E-mail fonctionnel.

Mytå

 

[Guido]

Re

Oui Guido, E-mail fonctionnel.

Mytå

Re

Ok

a plus

Guido

 

[job75]

Re, bonsoir chère ânesse , Mytå,

Si la plage de destination peut être n'importe où ce n'est guère plus compliqué :

Sub Impairs()
Dim source As Range, dest As Range, ad$
Set source = [K2:K19] 'plage à copier, à adapter
Set dest = [M5] '1ère cellule de destination
ad = source(1).Address(0, RelativeTo:=dest)
With dest.Resize(source.Rows.Count)
  .Formula = "=IF(MOD(" & ad & ",2)," & ad & ","""")"
  .Value = .Value
End With
End Sub

Sub Pairs()
Dim source As Range, dest As Range, ad$
Set source = [K2:K19] 'plage à copier, à adapter
Set dest = [M5] '1ère cellule de destination
ad = source(1).Address(0, RelativeTo:=dest)
With dest.Resize(source.Rows.Count)
  .Formula = "=IF(NOT(MOD(" & ad & ",2))," & ad & ","""")"
  .Value = .Value
End With
End Sub

Fichier(2).

A+

 

[job75]

Bonjour Guido, le forum,

Les plage source et destination peuvent être dans des feuilles différentes :

Sub Impairs()
Dim source As Range, dest As Range, ad$
Set source = Feuil2.[K2:K19] 'plage à copier, à adapter
Set dest = Feuil3.[A2] '1ère cellule de destination, à adapter
ad = source(1).Address(0, External:=True, RelativeTo:=dest)
With dest.Resize(source.Rows.Count)
  .Formula = "=IF(MOD(" & ad & ",2)," & ad & ","""")"
  .Value = .Value
End With
dest(0) = "Impairs"
Application.Goto dest(0) 'facultatif
End Sub

Sub Pairs()
Dim source As Range, dest As Range, ad$
Set source = Feuil2.[K2:K19] 'plage à copier, à adapter
Set dest = Feuil3.[A2] '1ère cellule de destination, à adapter
ad = source(1).Address(0, External:=True, RelativeTo:=dest)
With dest.Resize(source.Rows.Count)
  .Formula = "=IF(NOT(MOD(" & ad & ",2))," & ad & ","""")"
  .Value = .Value
End With
dest(0) = "Pairs"
Application.Goto dest(0) 'facultatif
End Sub

Fichier (3).

Bonne journée.

 

[Guido]

Bonjour Job75 et le Forum

Merci pour cette proposition.

je pense avoir l'embarras du choix, encore ,Merci.

je vais clore ce post.

Amitiés

Guido