à date...

[Demouret]

Bonsoir les Xldistes..

Besoin d'un p'tit coup de main... :unsure:

J'ai une feuille 'contacts' dans laquelle je gère mes clients et mes devis.

Afin d'assurer un bon suivi j'ai crée une feuille 'rappels' vers laquelle j'exporte les données (lignes completes) des clients que je veux rappeler à une date ulterieure définie..

En fait je voudrai que lorsque la date du jour est superieure ou égale à la date du rappel la ligne complête revienne sur ma feuille 'contacts'

J' ai bien tenté d'écrire ça mais bof bof...
(ma date de rappel se trouve en colonne L et le nom de mon contacts en colonne F )

Private Sub Workbook_Open()

Dim dest As Range
Dim cell As Range
Set dest = sheets('Contacts').Range('F65536').End(xlUp).Offset(1, 0)
dest.Select

With sheets('rappels')

For Each cell In .Range('L1:L' & .Range('L65536').End(xlUp).Row)
If cell.Value < Date Then
cell.Select ' ca a l'air de coincer là...
End If
Next cell
Cells(ActiveCell.Row, 6).Select
Range(ActiveCell, ActiveCell.Offset(0, 100)).Cut Destination:=dest
sheets('contacts').Activate

End With
End Sub


Merci d'avance et bon WE à vous tous

 

[G.David]

salut
peut etre
With sheets('rappels')
t=0
For Each cell In .Range('L1:L' & .Range('L65536').End(xlUp).Row)
t=t+1
If cell.Value < Date Then
cell.Select ' ca a l'air de coincer là...
cells(t,15).select
End If
Next cell
Cells(ActiveCell.Row, 6).Select
Range(ActiveCell, ActiveCell.Offset(0, 100)).Cut Destination:=dest
sheets('contacts').Activate

End With
End Sub
sans plus de conviction
G.David

 

[Demouret]

Ca m'a l'air pas mal du tout ça...

J'ai juste un pbme de colonne qui ne coincident plus mais je devrais regler ca demain matin sans trop de soucis...(plus envie ce soir)


Merci beaucoup David et passe un bon Week...

 

[Demouret]

mmh mmh !!


Désolé David mais j'ai parlé un peu vite...
ca n'a pas l'air de fonctionner tout à fait...


On verra ca demain

Merci

 

[Charly2]

Bonjour Demouret et G.David, bonjour à toutes et à tous

Peut-être une piste possible dans le code suivant :

Option Explicit

Private Sub Workbook_Open()
'
Dim CellDest As Range
Dim Ligne&
'
  Set CellDest = Sheets('Contacts').Range('F65536').End(xlUp) _
        .Offset(1, 0)

  With Sheets('rappels')

    For Ligne = .Range('L65536').End(xlUp).Row To 1 Step -1
      If .Cells(Ligne, 12) < Date Then
        .Cells(Ligne, 6).Resize(1, 101).Cut _
              Destination:=CellDest
        Set CellDest = CellDest.Offset(1, 0)
      End If
    Next Ligne

  End With
End Sub

Tiens nous au courant.

A+

 

[Demouret]

Bonjour Charly Bonjour le Forum

Bon début de piste Charly Merci pour tes lumières...

Il me coupe et me copie bien la ligne dans ma feuille 'contact' mais si j'en ai plusieurs il ne m'en coupe et colle qu'une seule et me met comme message d'erreur:
'erreur d'execution 424. Objet requis'
avec en surligné jaune dans editeur VBA:

Set CellDest = CellDest.Offset(1, 0)

Il faut aussi que je place quelque part la supression complete de la ligne en sheet'rappels'
On tiens le bon bout

Merci à vous...

 

[Charly2]

re,

J'oublie toujours d'être méfiant quand j'utilise la méthode Cut !!! :unsure: :whistle:

Enfin, correction effectuée

Option Explicit

Private Sub Workbook_Open()
'
Dim CellDest As Range
Dim Ligne&
'
  Set CellDest = Sheets('Contacts').Range('F65536').End(xlUp) _
        .Offset(1, 0)

  With Sheets('rappels')

    For Ligne = .Range('L65536').End(xlUp).Row To 1 Step -1
      If .Cells(Ligne, 12) < Date Then
        With .Cells(Ligne, 6).Resize(1, 101)
          .Copy Destination:=CellDest
          .EntireRow.Delete
        End With
        Set CellDest = CellDest.Offset(1, 0)
      End If
    Next Ligne

  End With
End Sub

J'espère que ça ira cette fois.

A+

Message édité par: Charly2, à: 25/03/2006 21:12

 

[Demouret]

Un vrai magicien ce Charly....

Cela fonctionne à merveille. Merci beaucoup Charly, merci David.
Grace à vous elle commence à être sympa ma petite appli...

Bon Dimanche à vous tous