Recherche dans string pour copier/coller à côté

Bonjour,

Je vous écris pour avoir un peut d'aide sur un petit code qui ne fonctionne pas totalement. En effet, voici la fonction que je souhaiterai lui donner:

Dans une colonne je dispose d'une liste de données (avec coups, des quantités...) réparties dans des comptes du type : INSTALLATION PRINCIPALE (001).

Toutes ces données se trouvent dans la colonne B. Ces données s’altèrent: il y a d'abord l'intitulé du compté, puis la liste des libellés qui entrent dans ce compte. Puis vient le second compte et tout ses libellés, etc.

J'aimerai pouvoir récupérer le numéro du compte (ici 001), le copier puis le coller dans la colonne de gauche, A, qui est vide.

J'ai réussi à récupérer ce numéro de compte, mais j' n'arrive pas à réaliser... un copier/coller ...

    Sheets("comptes").Select
    For Each Cell In Columns("B:B").Cells
    On Error Resume Next
        If UCase(Cell.Text) Like "* (###)" Then
            x = Cell.Value
            code = Mid(Right(UCase(x), 4), 1, 3)
            code.Copy
            ActiveCell.Offset(0, -1).Select
            ActiveSheet.Paste
        End If
    Next

Est-ce que quelqu'un comprend ce qui ne fonctionne pas ?

De plus, cette recherche est très longue à réaliser (presque 15 sec alors que je l'ai testé sur seulement 200 lignes ...). Y aurait il un moyen de l'accélérer un peut?

Je vous remercie par avance pour votre aide.

A bientôt

Bonsoir

Sans fichier pour tester

A essayer

Sub Test()
Dim J As Long

  With Sheets("comptes")
    For J = 1 To .Range("B" & Rows.Count).End(xlUp).Row
      If .Range("B" & J) Like "* (###)" Then
        .Range("A" & J) = Mid(Right(Range("B" & J), 4), 1, 3)
      End If
    Next J
  End With
End Sub

Si pas ça

Bonjour,

Merci beaucoup pour votre aide! Même sans le fichier, votre code fonctionne parfaitement !

Encore merci !