transfert cellules lignes avec condition puis suppression ligne

[cathodique]

Bonsoir Le Forum,

Afin de réduire le nombre de lignes d'un tableau, je voudrai d'abord transférer certaines cellules de lignes spécifiques avec conditions en colonne (observation), puis les supprimer.

je risque d'être confus dans l’exposé de mon problème, je joins un fichier qui j'espère sera plus explicite.

nb: le problème est exposé sur le feuille "cas tiers". votre solution sera intégrée au traitement de la feuille "consult".

En vous remerciant par avance.

Cordialement,

 

[cathodique]

[Résolu]: transfert cellules lignes avec condition puis suppression ligne

Bonsoir Le Forum,

Dans ma caverne, j'ai délogé un vieux fichier dont je suis inspiré pour solutionner mon problème.
Merci à tous ceux qui ont lu mon message. Je reconnais que j'ai très mal posé mon problème.
Voici mon code testé, ça pourrait être utile🙂

Sub Transfert_suppression_Tiers()

Dim bd As Object
Dim i As Integer, a As Integer
Dim lig As Integer
Dim pl As Range, cell As Range
Dim Nposte As String, Obs As String
Dim dl As Long
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Application.ScreenUpdating = False

Set bd = Sheets("Consult") 'définit l'onglet bd
dl = bd.Cells(Application.Rows.Count, 1).End(xlUp).Row
Set pl = bd.Range("B8:B" & dl) 'définit la plage 

'Transfert données "Tiers"  en observation et suppression lignes contenant "tiers"

Bsuivant:
    With pl
        Set n = .Find(what:="Tiers", LookIn:=xlValues, LookAt:=xlWhole)
   End With
    If Not n Is Nothing Then
        lig = n.Row
 
    Nposte = Cells(lig, 4)
    Obs = Cells(lig, 10) & Chr(10) & Cells(lig, 13)
    
    
    bd.Range("A:D").AutoFilter 4, Nposte
  
Set Plage = pl.SpecialCells(xlCellTypeVisible)
    For Each cell In Plage
    a = cell.Row
        If UCase(cell) = "G" And Cells(a, 3) = "G1" Then
        bd.Cells(a, 13) = Cells(a, 13) & Chr(10) & Obs
        bd.Cells(lig, 1).EntireRow.Delete
        End If
        
        If UCase(cell) = "O" And Cells(a, 3) = "O1" Then
        bd.Cells(cell.Row, 13) = Cells(a, 13) & Chr(10) & Obs
        bd.Cells(lig, 1).EntireRow.Delete
        End If
    
    Next cell
 
Set Plage = Nothing
bd.Cells.AutoFilter
GoTo Bsuivant
 
    Else: Exit Sub
    End If

End Sub

Problème résolu.

Bonne soirée.

Cordialement,