Anomalie fonction Derligne

Bonjour,

Je vous joins un fichier avec le code accessible dans lequel nous enregistrons des données de chiens que nous diffusons pour adoption, or, lorsque que nous entrons des chiens avec un nom commençant par Y ou Z, les lignes s'écrasent les unes sur les autres au lieu de s'incrémenter les unes en dessous des autres.

Je pense que le problème provient de la fonction Derligne mais je n'en suis pas certain et je ne sais pas comment résoudre malgré la multitude de mes essais.

Je vous remercie pour votre aide et vous souhaite une bonne fin de week-end

Cordialement

Bonjour

pas de function pour dlg

voila la bonne syntaxe

dlg = .Range("A" & Rows.Count).End(xlUp).Row + 1

A+

Maurice

Bonjour

Je viens de regarde ton code en vitesse... en particulier la fonction "DerLigne" qui utilise une méthode que je trouve un peu compliquée !

Mais bref, je pense que ton problème vient plutôt du Filtre !

Bonsoir Archer et Gli73,

J'ai tenté de virer la fonction dans les essais que j'ai fait mais j'ai une autre anomalie qui apparaît, je vais essayé d'approfondit

Concernant le filtre, j'ai essayé sans et le problème est toujours présent

Merci pour vos idées

Cdlt

Bonjour,

J'essaie actuellement de supprimer la fonction dernlign, cependant, je me heurte à un souci, en effet en modifiant, lorsque j'entre une nouvelle ligne, elle s'incrémente en ligne 1000

Actuellement, j'ai 151 lignes de renseignées, j'utilise ce code qui conserve la dimension du tableau "Diffusion" à chaque entrée via le USF:

ActiveSheet.ListObjects("Diffusion").Resize Range("$A$1:$U$1000")

J'aimerais que celui-ci se dimensionne à la dernière ligne renseignée via le USF et s'incrémente à chaque nouvelle entrée.

Je vous remercie

Cordialement

Bonjour,

Pour commencer, supprime toutes les lignes du tableau diffusion qui sont inutiles (> ligne 151).

Ensuite copie ce code pour l'insertion de ligne dans ton code.

A tester !...

Cdlt.

Set lo = Range("diffusion").ListObject

    With lo
        If .InsertRowRange Is Nothing Then
            Set rCell = .HeaderRowRange.Cells(1).Offset(.ListRows.Count + 1)
        Else
            Set rCell = .InsertRowRange.Cells(1)
        End If
    End With

    With rCell
        .Value = Nom
        .Offset(, 2).Value = Sexe
        .Offset(, 3).Value = Race
        .Offset(, 4).Value = LabelDateNaiss
        .Offset(, 5).Value = Calcul_age(.Range("E" & dlg), Now()) '????
        .Offset(, 6).Value = Garrot
        .Offset(, 7).Value = Poids
        .Offset(, 8).Value = Refuge
        .Offset(, 9).Value = LabelDateArr
        .Offset(, 10).Value = Cong
        .Offset(, 11).Value = Chat
        .Offset(, 12).Value = Enfant
        .Offset(, 13).Value = Stat
        .Offset(, 15).Value = chemin
        .Offset(, 16).Value = Chance
        .Offset(, 17).Value = Fonds
        .Offset(, 18).Value = reseau
        .Offset(, 19).Value = Wamiz
        .Offset(, 20).Value = Facebook
    End With

Bonsoir,

Vous devez apprendre à vous servir d'un tableau structuré.

1- il ne doit pas comporter de lignes vides

2- l'insertion d'une nouvelle ligne recopie automatiquement formats et formules

3- l'objet VBA associé est "ListObject". L'utilisation de ces méthodes et propriétés simplifie le code.

Par ailleurs, votre gestion d'insertion d'image est sacrément compliquée. Je l'ai donc révisée : 2 lignes de code sont suffisantes.

ci-joint votre fichier modifié

Bonsoir Thev et Jean-Eric,

Merci pour vos propositions, Thev, c'est génial votre code, cependant, un souci nouveau se présente, lors de la copie des adoptés, les photos des lignes copiées ne se suppriment pas et de plus les photos se déforment dans la liste adoptés

Cdlt

Fabien

Fabien62 a écrit :

lors de la copie des adoptés, les photos des lignes copiées ne se suppriment pas et de plus les photos se déforment dans la liste adoptés

précisez comment vous effectuez la copie des adoptés.

Bonjour Thev,

J'ai un bouton en V1:W1 avec ce code dans la feuil1

Private Sub CommandButton1_Click()
Dim N_img As Shape
Dim nomph As String
Dim PR As Worksheet, AV As Worksheet, iAV&, i& ' oui
Dim xPicRg As Range, xrg As Range   ' oui

' DimTableau Macro
Range("Diffusion").Select
Application.CutCopyMode = False
ActiveSheet.ListObjects("Diffusion").Resize Range("$A$1:$U$1000")

Set PR = Sheets("Liste diffusion")
Set AV = Sheets("Liste Adoptés")

iAV = AV.Range("A1000").End(xlUp).Row + 1

With PR.[A1].CurrentRegion.Resize(, 16)
    '---copie les lignes et leurs hauteurs---
    For i = 2 To .Rows.Count
        If .Cells(i, 14) = "Adopté" Then
            .Rows(i).Copy AV.Cells(iAV, 1)
            AV.Rows(iAV).RowHeight = .Rows(i).RowHeight

            iAV = iAV + 1

         .EntireRow(i).Delete Shift:=xlShiftUp ' on peut mettre en com. pour des essais'
         i = i - 1
        End If
    Next
    '---copie les largeurs des colonnes---
    For i = 1 To 16
        AV.Columns(i).ColumnWidth = .Columns(i).ColumnWidth
    Next
    AV.Columns(16).Hidden = True
End With
Call HyperLink  ' sub mise à part pour debug
  Application.CutCopyMode = False: Cells(Application.Rows.Count, Application.Columns.Count).Copy: Application.CutCopyMode = False
End Sub

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
If Not Intersect(Target, Range("A2:A5000")) Is Nothing Then

T = Target.Row
If Target.Count > 1 Then Exit Sub
Saisie.Show 0
End If

rg = Target.Address
Col = Target.Column
rang = Target.Row
If Col = 16 Then LienHT

End Sub

Cordialement

Bonjour,

Pour votre copie des adoptés, un simple filtrage avancé me parait suffisant.

ci-jointe version

Bonjour,

Je vous remercie mais ca ne me vas pas, les chiens adoptés doivent ce supprimer de la liste de diffusion, dans mon fichier initial tout fonctionne correctement sauf que j'ai un souci avec le dimensionnement du tableau et avec les noms de chiens qui s'écrasent lorsqu'ils commencent par Y ou Z.

Je vais essayez de résoudre cela car au final j'ai plus de soucis qu'auparavant

Je vous remercie pour votre temps et vos propositions

Cordialement

Fabien62 a écrit :

ca ne me vas pas, les chiens adoptés doivent ce supprimer de la liste de diffusion

ci-jointe une nouvelle version qui devrait mieux vous convenir

Un grand Merci Thev, j'ai également trouvé une solution de mon côté, au moins j'aurais appris des choses depuis deux jours

Cordialement

Fabien62 a écrit :

j'ai également trouvé une solution de mon côté, au moins j'aurais appris des choses depuis deux jours

Parfait.

Après revérification de ma version, j'ai procédé à quelques ajustements.

ci-jointe version finale si elle peut être utile

Merci beaucoup Thev,

Je vais l'étudier

Cordialement