Traitement de chaîne de caractère

zephir29 · 6 Avril 2017

Bonjour,

Je débute ici, j'espère que vous serais tolérant

J'ai une cellule contenant des tag définis.
Cellule i;j =
_Tag1_ : abc
_Tag2_ : def
_Tag3_ : ghi
....
Je souhaiterais extraire le contenu de cette cellule et le placer dans différente colonne en fonction des tags.
Si Tag1 dispo alors copie de "abc" dans colonnes X
Sinon check de Tag2
Si Tag1 dispo alors copie de "def" dans colonnes Y
Ainsi de suite.

Voici ce que j'ai fait et qui biensûr ne fonctionne pas

Sub convertir_V()

Const SYSTEMCONF As Integer = 3
Const EXTERNALREF As Integer = 10
Const MAXTAGSEARCH As Integer = 4
Const COLUMNOFFSET As Byte = 4

Dim cptr As Byte
Dim TabloTag(MAXTAGSEARCH) As String
Dim StringSearch As String
Dim IndexFoundSearch As Integer
Dim IndexBrowse As Integer
Dim Tablo() As String
Dim Tableau() As String

TabloTag(0) = "Tag1"
TabloTag(1) = "Tag2"
TabloTag(2) = "Tag3"
TabloTag(3) = "Tag4"

lignes = Range("C65536").End(xlUp).Row
For IndexBrowse = 1 To lignes
For IndiceSearch = 1 To MAXTAGSEARCH
StringSearch = Cells(IndexBrowse, SYSTEMCONF)
IndexFoundSearch = InStr(1, StringSearch, TabloTag(IndiceSearch - 1))
If IndexFoundSearch Then
Tablo = Split(Left(StringSearch, IndexFoundSearch), Chr(10))
If (UBound(Tablo) >= 0) Then
For cptr = 0 To UBound(Tablo)
Tableau = Split(Tablo(cptr), ":")
On Error Resume Next
Cells(IndexBrowse, COLUMNOFFSET + IndiceSearch) = Trim(Tableau(1))
Next
End If
End If
Next
Next
End Sub

Compte Supprimé 979 · 7 Avril 2017

Bonjour Zephir29

Je ne vois pas très bien comment ton fichier est articulé !?

Peux-tu nous mettre un exemple STP ?

A+

zephir29 · 7 Avril 2017

Bonjour BrunoM45,

Je viens de joindre mon fichier en exemple.

Crdlt,

zephir29.

job75 · 7 Avril 2017

Bonsoir zephir29, hello Bruno,

En ligne 1 il y a ce que vous appelez les "tags", autant les utiliser.

Et cette fonction VBA est bien simple :

Code:

Function RechercheTag$(t$, tag$)
Dim deb%, fin%
deb = InStr(t, tag)
If tag = "" Or deb = 0 Then Exit Function
deb = deb + Len(tag)
t = t & vbLf 'bornage
fin = InStr(deb, t, vbLf)
RechercheTag = Trim(Replace(Mid(t, deb, fin - deb), ":", ""))
End Function

Elle fonctionne qu'il y ait ou non un ":" à la fin du "tag".

Fichier joint, attention il était en mode de calcul Manuel, je l'ai passé en Automatique !!!

A+

job75 · 7 Avril 2017

Re,

Même si l'on préfère une procédure Sub on utilisera la fonction précédente :

Code:

Private Sub Worksheet_Change(ByVal Target As Range)
Dim ligTag&, colTexte%, P As Range
ligTag = 1 'ligne des tags, à adapter
colTexte = 3 'colonne C, à adapter
Application.ScreenUpdating = False
Application.EnableEvents = False
Set P = Cells(ligTag + 1, colTexte + 1).Resize(Rows.Count - ligTag, Columns.Count - colTexte)
P = "" 'RAZ
Set P = Intersect(P, Me.UsedRange)
If Not P Is Nothing Then
  P.FormulaR1C1 = "=RechercheTag(RC" & colTexte & ",R" & ligTag & "C)"
  P = P.Value 'supprime les formules
End If
Application.EnableEvents = True
End Sub

Notez qu'avec cette macro les résultats ne peuvent pas être effacés ou modifiés manuellement.

Fichier (2).

Bonne fin de soirée.

job75 · 8 Avril 2017

Bonjour zephir29, Bruno, le forum,

Si comme sur l'exemple il y a des cellules vides ceci est plus rapide :

Code:

Const ligTag& = 1 'ligne des tags, à adapter
Const colTexte% = 3 'colonne C, à adapter

Private Sub Worksheet_Change(ByVal Target As Range)
Application.ScreenUpdating = False
Application.EnableEvents = False
On Error Resume Next
With Cells(ligTag + 1, colTexte + 1).Resize(Rows.Count - ligTag, Columns.Count - colTexte)
  .Value = "" 'RAZ
  With Intersect(.Cells, Rows(ligTag).SpecialCells(xlCellTypeConstants).EntireColumn, _
    Columns(colTexte).SpecialCells(xlCellTypeConstants).EntireRow, Me.UsedRange)
    .FormulaR1C1 = "=RechercheTag(RC" & colTexte & ",R" & ligTag & "C)"
    .Value = .Value 'supprime les formules
  End With
End With
Application.EnableEvents = True
End Sub

Fichier (3).

Pour tester j'ai créé un tableau de 11 000 lignes.

Chez moi sur Win 10 - Excel 2013 la macro s'exécute en 1,70 seconde.

Bonne journée.

job75 · 8 Avril 2017

Re,

Sur le fichier précédent de 11 000 lignes 1,70 seconde c'est trop long.

Car c'est la même durée qu'on modifie tout le tableau ou une seule cellule.

Ceci y remédie, désolé si c'est un peu difficile à comprendre :

Code:

Const ligTag& = 1 'ligne des tags, à adapter
Const colTexte% = 3 'colonne C, à adapter

Private Sub Worksheet_Change(ByVal Target As Range)
Dim flag As Boolean
Application.ScreenUpdating = False
Application.EnableEvents = False
On Error Resume Next
With Intersect(Cells(ligTag + 1, colTexte + 1).Resize(Rows.Count - ligTag, Columns.Count - colTexte), Me.UsedRange)
  Intersect(Target, .Cells) = "" 'RAZ
  For Each Target In Intersect(Target, Me.UsedRange).Areas 'si entrées multiples (copier-coller)
    flag = True
    If Not Intersect(Target, Rows(ligTag), .Cells.EntireColumn) Is Nothing Then
      flag = False
      With Intersect(Target.EntireColumn, .Cells)
        .FormulaR1C1 = "=RechercheTag(RC" & colTexte & ",R" & ligTag & "C)"
        .Value = .Value 'supprime les formules
      End With
    End If
    If Not Intersect(Target, Columns(colTexte), .Cells.EntireRow) Is Nothing Then
      flag = False
      With Intersect(Target.EntireRow, .Cells)
        .FormulaR1C1 = "=RechercheTag(RC" & colTexte & ",R" & ligTag & "C)"
        .Value = .Value 'supprime les formules
      End With
    End If
    If flag Then
      With Intersect(Target, .Cells)
        .FormulaR1C1 = "=RechercheTag(RC" & colTexte & ",R" & ligTag & "C)"
        .Value = .Value 'supprime les formules
      End With
    End If
  Next
End With
Application.EnableEvents = True
End Sub

Fichier (2).

La modification d'une cellule ou d'une plage de quelques cellules est immédiate.

Le copier-coller de tout le tableau sur lui-même prend 4 secondes, c'est acceptable.

A+

zephir29 · 8 Avril 2017

Bonjour Job75,

Merci pour ce retour, effectivement ça n'a plus rien à voir avec mon code d'origine, et j'ai un peu de mal à comprendre.

Je souhaite quand même garder un tableau avec mais différents tag, car la ligne 1 n'existera pas au final.

Je dois effectuer plusieurs traitement sur un fichier excel avant d'importer les cellules ayant changée dans dans un autre fichier.
C'est pour cela que j'utilisais une procédure sub, la avec la fonction, je ne vois pas très bien comment l'insérer dans le code complet.

job75 · 8 Avril 2017

Re,

zephir29 à dit:
Je souhaite quand même garder un tableau avec mais différents tag, car la ligne 1 n'existera pas au final.

Avec cette macro le tableau Tags est à définir manuellement, l'affichage des tags en ligne 1 est facultatif :

Code:

Private Sub Worksheet_Change(ByVal Target As Range)
Tags = Array("Conti CQTS ref.", "Vehicule", "Km", "Start of warranty", "Country", "Dealer Brand", "Cal") 'liste des tags à adapter
Dim Prem As Range, col%, flag As Boolean
Set Prem = [PremièreCellule] 'cellule nommée
col = Prem.Column
Application.ScreenUpdating = False
Application.EnableEvents = False
On Error Resume Next
With Intersect(Prem.Resize(Rows.Count - Prem.Row + 1), Me.UsedRange).Columns(2).Resize(, UBound(Tags) + 1)
  For Each Target In Intersect(Target, Me.UsedRange).Areas 'si entrées multiples (copier-coller)
    flag = True
    If Not Intersect(Target, Columns(col), .Cells.EntireRow) Is Nothing Then
      flag = False
      With Intersect(Target.EntireRow, .Cells)
        .FormulaR1C1 = "=RechercheTag(RC" & col & ",COLUMN()-" & col & ")"
        .Value = .Value ' 'supprime les formules
      End With
    End If
    If flag Then
      With Intersect(Target, .Cells)
        .FormulaR1C1 = "=RechercheTag(RC" & col & ",COLUMN()-" & col & ")"
        .Value = .Value 'supprime les formules
      End With
    End If
  Next
  .Cells(0, 1).Resize(, UBound(Tags) + 1) = Tags 'affichage des tags facultatif ???
  .Columns.EntireColumn.AutoFit 'ajustement largeur des colonnes
End With
Application.EnableEvents = True
End Sub

Dans Module1 le tableau est mémorisé et la fonction a été un peu modifiée :

Code:

Public Tags 'mémorise la variable tableau

Function RechercheTag$(t$, ordre%)
Dim deb%, fin%
deb = InStr(t, Tags(ordre - 1))
If deb = 0 Then Exit Function
deb = deb + Len(Tags(ordre - 1))
t = t & vbLf 'bornage
fin = InStr(deb, t, vbLf)
RechercheTag = Trim(Replace(Mid(t, deb, fin - deb), ":", ""))
End Function

Fichier (3).

A+

job75 · 8 Avril 2017

Re,

S'il s'agit uniquement d'importer les textes à traiter c'est plus simple :

Code:

Const Source$ = "Fichier source.xlsx" 'nom à adapter
Const PremCel$ = "C2" '1ère cellule, modifiable

Private Sub CommandButton1_Click() 'Importer
Tags = Array("Conti CQTS ref.", "Vehicule", "Km", "Start of warranty", "Country", "Dealer Brand", "Cal") 'liste des tags à adapter
Dim col%
col = Range(PremCel).Column
Application.ScreenUpdating = False
On Error Resume Next 'si le fichier source n'est pas ouvert
Columns(col).Resize(, Columns.Count - col + 1) = "" 'RAZ
Columns(col).ColumnWidth = 100
With Workbooks(Source).Sheets(1).UsedRange.Offset(1) 'Offset(1) si titre
  .Copy Range(PremCel)
  With Range(PremCel).Offset(, 1).Resize(.Rows.Count, UBound(Tags) + 1)
    .FormulaR1C1 = "=RechercheTag(RC" & col & ",COLUMN()-" & col & ")"
    .Value = .Value ' 'supprime les formules
    .Cells(0, 1).Resize(, UBound(Tags) + 1) = Tags 'affichage des tags facultatif ???
  End With
End With
Columns(col).Resize(, Columns.Count - col + 1).AutoFit 'ajustement largeur des colonnes
End Sub

Fichiers joints.

Bonne fin de soirée.

zephir29 · 8 Avril 2017

Hello, merci pour le tableau.
Je ne vois pas bien ou est définit le colonne ou sont copié les valeurs.
En faite je souhaiterais pouvoir définir une "Const COLUMNOFFSET As Byte = 4" et dire que c'est à prtir de cette colonne que je place mes tags, dans l'ordre définit par mon tableau.

D'avance merci,

job75 · 8 Avril 2017

Re,

Il y avait des choses inutiles dans la macro précédente, je viens de la corriger.

Les données sources sont copiées vers la cellule dont l'adresse est définie par :

Code:

Const PremCel$ = "C2" '1ère cellule, modifiable

A+

zephir29 · 8 Avril 2017

Ok pour C2 c'est la ou est copié le contenu de toute la cellule, mais si je souhaite placer en G2 mon 1er extract de tag?
Comment je peux définir cette valeur, je ne vois pas comment c'est fait

job75 · 8 Avril 2017

Re,

La macro précédente décale les résultats d'une colonne par rapport à la cellule C2.

Mais vous pouvez paramétrer le décalage en définissant la variable decale :

Code:

Const Source$ = "Fichier source.xlsx" 'nom à adapter
Const PremCel$ = "C2" '1ère cellule, modifiable
Const decale As Byte = 4 'décalage des résultats

Private Sub CommandButton1_Click() 'Importer
Tags = Array("Conti CQTS ref.", "Vehicule", "Km", "Start of warranty", "Country", "Dealer Brand", "Cal") 'liste des tags à adapter
Dim col%
col = Range(PremCel).Column
Application.ScreenUpdating = False
On Error Resume Next 'si le fichier source n'est pas ouvert
Columns(col).Resize(, Columns.Count - col + 1).Delete 'RAZ
Columns(col).ColumnWidth = 100
With Workbooks(Source).Sheets(1)
  With .Range("A2:A" & .Range("A" & .Rows.Count).End(xlUp).Row) 'A2 si titre
    .Copy Range(PremCel)
    With Range(PremCel).Offset(, decale).Resize(.Rows.Count, UBound(Tags) + 1)
      .FormulaR1C1 = "=RechercheTag(RC" & col & ",COLUMN()" & 1 - col - decale & ")"
      .Value = .Value ' 'supprime les formules
      .Rows(0) = Tags 'affichage des tags facultatif ???
    End With
  End With
End With
Columns(col).Resize(, Columns.Count - col + 1).AutoFit 'ajustement largeur des colonnes
With Me.UsedRange: End With 'actualise les barres de défilement
End Sub

Fichier (2).

Bonne nuit.

zephir29 · 9 Avril 2017

Super ça ça devrait fonctionner.
Je vous remercie pour votre temps.

Bonne nuit

Traitement de chaîne de caractère

XLDnaute Nouveau

Compte Supprimé 979

Guest

XLDnaute Nouveau

Pièces jointes

XLDnaute Barbatruc

Pièces jointes

XLDnaute Barbatruc

Pièces jointes

XLDnaute Barbatruc

Pièces jointes

XLDnaute Barbatruc

Pièces jointes

XLDnaute Nouveau

XLDnaute Barbatruc

Pièces jointes

XLDnaute Barbatruc

Pièces jointes

XLDnaute Nouveau

XLDnaute Barbatruc

XLDnaute Nouveau

XLDnaute Barbatruc

Pièces jointes

XLDnaute Nouveau

Discussions similaires

Partager cette page

Statistiques des forums