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

job75 · 9 Avril 2017

Bonjour zephir29, le forum,

J'ai améliorée la macro précédente, en particulier pour que les barres de défilement soient actualisées.

En effet la plage importée peut être de hauteur variable.

Bonne journée.

job75 · 9 Avril 2017

Re,

Avec cette macro on n'utilise plus la fonction VBA, c'est plus rapide :

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
Dim Tags, ub%, col%, mat, resu$(), i&, x$, j%, y$, deb%, fin%
Tags = Array("Conti CQTS ref.", "Vehicule", "Km", "Start of warranty", "Country", "Dealer Brand", "Cal") 'liste des tags à adapter
ub = UBound(Tags)
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)
    '---analyse des textes---
    mat = .Resize(, 2) 'matrice, plus rapide, au moins 2 éléments
    ReDim resu(1 To .Rows.Count, 0 To ub)
    For i = 1 To UBound(mat)
      x = mat(i, 1)
      For j = 0 To ub
        y = Tags(j)
        deb = InStr(x, y)
        If deb Then
          deb = deb + Len(y)
          x = x & vbLf 'bornage
          fin = InStr(deb, x, vbLf)
          resu(i, j) = Trim(Replace(Mid(x, deb, fin - deb), ":", ""))
        End If
    Next j, i
    '---restitution des résultats
    With Range(PremCel).Offset(, decale).Resize(.Rows.Count, ub + 1)
      .Value = resu
      .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 (3), durée d'exécution 1,7 seconde contre 3,1 secondes pour le fichier (2).

A+

zephir29 · 9 Avril 2017

Bonjour Job75,

L'import se fait après le traitement, mais ça c'est déjà en place, donc pas besoin de l'inclure.
Là j'ai juste une colonne C(à définir par Cons) dans laquelle j'ai toute mes infos et je souhaite en extraire mes tags à partir de la colonne Y(à définir par Cons) et dans l'ordre définit par le tableau Tags.
Il est vrai que sans la fonction ça me parait plus simple et compréhensible

Merci pour le soutien.

job75 · 9 Avril 2017

Re,

La feuille source et les résultats peuvent être dans le même classeur :

Code:

Const PremCelSource$ = "B4" '1ère cellule source, modifiable
Const PremCelResultat$ = "C2" '1ère cellule des résultats, modifiable
Const decale As Byte = 4 'décalage des résultats

Sub Traitement()
Dim Tags, ub%, S As Worksheet, R As Worksheet, nlig&, col%, mat, resu$(), i&, x$, j%, y$, deb%, fin%
Tags = Array("Conti CQTS ref.", "Vehicule", "Km", "Start of warranty", "Country", "Dealer Brand", "Cal") 'liste des tags à adapter
ub = UBound(Tags)
Set S = Sheets("Source"): Set R = Sheets("Résultat")
nlig = S.Cells(Rows.Count, S.Range(PremCelSource).Column).End(xlUp).Row - S.Range(PremCelSource).Row + 1
Application.ScreenUpdating = False
With R
  col = .Range(PremCelResultat).Column
  .Columns(col).Resize(, .Columns.Count - col + 1).Delete 'RAZ
  If nlig < 1 Then Exit Sub
  .Columns(col).ColumnWidth = 100
  S.Range(PremCelSource).Resize(nlig).Copy .Range(PremCelResultat)
  '---analyse des textes---
  mat = .Range(PremCelResultat).Resize(nlig, 2) 'matrice, plus rapide, au moins 2 éléments
  ReDim resu(1 To nlig, 0 To ub)
  For i = 1 To UBound(mat)
    x = mat(i, 1)
    For j = 0 To ub
      y = Tags(j)
      deb = InStr(x, y)
      If deb Then
        deb = deb + Len(y)
        x = x & vbLf 'bornage
        fin = InStr(deb, x, vbLf)
        resu(i, j) = Trim(Replace(Mid(x, deb, fin - deb), ":", ""))
      End If
  Next j, i
  '---restitution des résultats
  With .Range(PremCelResultat).Offset(, decale).Resize(nlig, ub + 1)
    .Value = resu
    If .Row > 1 Then .Rows(0) = Tags 'affichage des tags, facultatif ?
  End With
  .Columns(col).Resize(, .Columns.Count - col + 1).AutoFit 'ajustement largeur des colonnes
  With .UsedRange: End With 'actualise les barres de défilement
  .Activate
End With
End Sub

La macro est lancée par un bouton, elle peut aussi être appelée par une Worksheet_Activate.

Fichier joint.

A+

zephir29 · 9 Avril 2017

Hello Job75,

Je cherche vraiment un truc plus simple.
Sur 1 même feuille j'ai comme dans l'exemple ci-joint des infos qui sont en colonne A, B, D, E, F, G....O.
En colonne C, ma fameuse colonne sur laquelle je souhaite extraire les infos et les mettre à partir de la colonne AA.
Ensuite j'ai du traitement qui se passe bien sur ce même fichier(Split entre autre)
Une fois que j'ai terminé tout ces traitements, je passe à l'import des cellules qui auront changées par rapport à mon ancienne version; mais ceci se passe également bien(Pour le moment...).

job75 · 9 Avril 2017

Re,

Il me paraît difficile de faire plus simple que ça :

Code:

Sub Traitement()
'se lance par Ctrl+T
Dim Tags, ub%, col%, nlig&, mat, resu$(), i&, x$, j%, y$, deb%, fin%
Tags = Array("Conti CQTS ref.", "Vehicule", "Km", "Start of warranty", "Country", "Dealer Brand", "Cal") 'liste des tags à adapter
ub = UBound(Tags)
col = 27 'colonne AA des résultats, à adapter
Application.ScreenUpdating = False
With Sheets("Feuil1") 'nom à adapter
  nlig = .Range("C" & Rows.Count).End(xlUp).Row - 1
  .Columns(col).Resize(, .Columns.Count - col + 1).Delete 'RAZ
  '---analyse des textes---
  mat = .[C2].Resize(nlig, 2) 'matrice, plus rapide, au moins 2 éléments
  ReDim resu(1 To nlig, 0 To ub)
  For i = 1 To UBound(mat)
    x = mat(i, 1)
    For j = 0 To ub
      y = Tags(j)
      deb = InStr(x, y)
      If deb Then
        deb = deb + Len(y)
        x = x & vbLf 'bornage
        fin = InStr(deb, x, vbLf)
        resu(i, j) = Trim(Replace(Mid(x, deb, fin - deb), ":", ""))
      End If
  Next j, i
  '---restitution des résultats
  With .Cells(2, col).Resize(nlig, ub + 1)
    .Value = resu
    .Rows(0) = Tags 'affichage des tags
  End With
  .Columns(col).Resize(, .Columns.Count - col + 1).AutoFit 'ajustement largeur des colonnes
  With .UsedRange: End With 'actualise les barres de défilement
  .Activate
End With
End Sub

Votre fichier en retour.

A+

zephir29 · 11 Avril 2017

Bonsoir Job75;
C'est tout simplement tip top!
Merci à vous pour ceci

Crdlt,

zephir29.

Traitement de chaîne de caractère

zephir29

XLDnaute Nouveau

job75

XLDnaute Barbatruc

job75

XLDnaute Barbatruc

Pièces jointes

zephir29

XLDnaute Nouveau

job75

XLDnaute Barbatruc

Pièces jointes

zephir29

XLDnaute Nouveau

Pièces jointes

job75

XLDnaute Barbatruc

Pièces jointes

zephir29

XLDnaute Nouveau

Discussions similaires