XL 2016 Extraire texte cellules fusionnées et copié sur une ligne

[roybaf]

Bonjour à tous,

J'ai un problème sur un fichier excel ou je n'arrive pas a avoir sur une seule ligne une série d'information.

Vous verrez sur le fichier exemple mes valeurs ne se recopies pas une par ligne mais à la ligne dans une cellule fusionnée, quelqu'un a t-il une idée de comment je pourrais lire la cellule fusionnée et à chaque retour à la ligne copié valeur et coller sur nouvelle ligne.

Merci d'avance pour votre aide.

 

[CISCO]

Bonjour

Prenons un exemple, E15 :
Est-ce que tu veux avoir

BNP 323 K€ BNP 323 K€ BNP 323 K€ BNP 323 K€ BNP 323 K€ BNP 323 K€ BNP 323 K€ BNP 323 K€ BNP 323 K€ BNP 323 K€ BNP 323 K€ BNP 323 K€ BNP 323 K€ BNP 323 K€

Totaux du compte 16410000000

dans deux cellules l'une en dessous de l'autre, ou dans 15 cellules les unes en dessous des autres ?

@ plus

 

[roybaf]

Bonjour,

Les unes en dessous des autres dans 15 cellules differentes

 

[roybaf]

Merci cisco

 

[CISCO]

Bonsoir

Et que devrait donner E1, une ou deux lignes ?

@ plus

 

[roybaf]

Bonjour cisco,

En faite sur le fichier mis en exemple je voudrais une ligne par date, on voit que ma conversion de pdf en excel ma mis des données dans des cellules fusionnée alors que j'aurais du avoir une ligne par date avec libellée , journal, montant, solde.

Comme pour la ligne 14

 

[CISCO]

Bonjour

OK, je pense avoir compris. J'espérai y arriver simplement avec "Données", "Convertir", mais ce n'est pas le cas. C'est certainement faisable avec une macro, mais, vu mon niveau dans ce domaine, pour le moment je ne vois pas trop la méthode à utiliser. J'essayerai un peu plus tard.

@ plus

 

[job75]

Bonjour roybaf, CISCO,

C'est un problème intéressant avec de nombreux détails qui n'ont pas été faciles à régler.

Voyez le fichier joint et cette macro dans Module1 (Alt+F11) :

Sub Resultat()
Dim r As Range, i&, n, sA, sB, sC, sE, sF, sH, sI, sK, j
Application.ScreenUpdating = False
On Error Resume Next
Set r = Feuil1.UsedRange 'tableau de la feuille Original
With Feuil2 'CodeName de la feuille Résultat
  .Cells.Clear 'RAZ
  .[A1].Resize(r.Rows.Count, r.Columns.Count) = r.Value 'copie les valeurs
  .[E:E].Replace "€", "€" & vbLf
  .[E:E].Replace String(3, vbLf), String(2, vbLf)
  For i = .Range("A" & .Rows.Count).End(xlUp).Row To 1 Step -1
    Set r = .Cells(i, 1)
    n = (Len(r(1, 5)) - Len(Replace(r(1, 5), vbLf, ""))) + 1
    .Rows(i).Resize(n).Insert 'insertion de n lignes
    sA = Split(r, vbLf): sB = Split(r(1, 2), "E")
    sC = Split(r(1, 3), vbLf): sE = Split(r(1, 5), vbLf)
    sF = Split(r(1, 6), vbLf): sH = Split(r(1, 8), vbLf)
    sI = Split(r(1, 9), vbLf): sK = Split(r(1, 11), vbLf)
    For j = 0 To n - 1
      If IsDate(sA(j)) Then .Cells(i + j, "A") = CDate(sA(j)) Else .Cells(i + j, "A") = sA(j)
      .Cells(i + j, "B") = Trim(sB(j))
      .Cells(i + j, "C") = sC(j): .Cells(i + j, "E") = sE(j)
      If IsNumeric(sF(j)) Then .Cells(i + j, "F") = CDbl(sF(j)) Else .Cells(i + j, "F") = sF(j)
      If IsNumeric(sH(j)) Then .Cells(i + j, "H") = CDbl(sH(j)) Else .Cells(i + j, "h") = sH(j)
      .Cells(i + j, "I") = Trim(sI(j))
      If IsNumeric(sK(j)) Then .Cells(i + j, "K") = CDbl(sK(j)) Else .Cells(i + j, "k") = sK(j)
    Next j
    If Cells(i, 1) = "Date" Then 'ligne des titres
      .Rows(i).Font.Bold = True 'gras
      .Rows(i).Font.ColorIndex = 2 'blanc
      .Cells(i, 1).Resize(, 11).Interior.ColorIndex = 23 'bleu
    End If
    With .Rows(i + n - 1) 'ligne des totaux
      If .Cells(5) Like "Totaux*" Then
        .Resize(, 11).Font.Bold = True 'gras
      ElseIf Application.CountA(.Rows) = 0 Then
        .Delete 'suppression si la ligne est vide
      End If
    End With
    r.EntireRow.Delete 'suppression de la ligne originale
  Next i
  .[F:K].NumberFormat = "#,##0.00" 'format nombre
  .Rows.RowHeight = 15
  .Columns.AutoFit 'ajustement largeur
  .Activate
End With
End Sub

A+

 

[CISCO]

Bonjour à tous, bonjour Job75

Bonjour roybaf, CISCO,

C'est un problème intéressant avec de nombreux détails qui n'ont pas été faciles à régler.
...
A+

Certainement, et je n'aurai tout aussi certainement pas réussi à le résoudre seul. Il ne me reste plus qu'à essayer de comprendre ta macro, Job75.

@ plus

 

[job75]

Re,

Oui CISCO et toutes les subtilités ne sont pas évidentes.

Dans ce fichier (2) plus besoin de bouton, il suffit d'activer la feuille "Résultat".

Clic droit sur son onglet et Visualiser le code.

A+

 

[job75]

Bonjour roybaf, CISCO, le forum,

L'insertion, la suppression, la mise en forme des lignes prennent beaucoup de temps.

Sur un grand tableau cette macro est beaucoup plus rapide car elle utilise des tableaux VBA :

Private Sub Worksheet_Activate()
Dim t, i&, n&, rest(), sA, sB, sC, sE, sF, sH, sI, sJ, sK, j
Application.ScreenUpdating = False
On Error Resume Next
'---préparation---
[A:K].ClearContents 'RAZ
With Feuil1.UsedRange.Resize(, 11) 'tableau de la feuille Original
  [A1].Resize(.Rows.Count, 11) = .Value 'copie les valeurs
End With
[E:E].Replace "€", "€" & vbLf
[E:E].Replace String(3, vbLf), String(2, vbLf)
t = Range("A1:L" & Range("A" & Rows.Count).End(xlUp).Row) 'matrice plus rapide, 1 colonne en plus
'---détermination du nombre de lignes du tableau rest---
For i = 1 To UBound(t)
  t(i, 12) = Len(t(i, 5)) - Len(Replace(t(i, 5), vbLf, ""))
  n = n + t(i, 12) + 1
Next
ReDim rest(1 To n, 1 To 11)
n = 1
'---remplissage du tableau rest---
For i = 1 To UBound(t)
  sA = Split(t(i, 1), vbLf): sB = Split(t(i, 2), " E"): sC = Split(t(i, 3), vbLf)
  sE = Split(t(i, 5), vbLf): sF = Split(t(i, 6), vbLf): sH = Split(t(i, 8), vbLf)
  sI = Split(t(i, 9), vbLf): sJ = Split(t(i, 10), vbLf): sK = Split(t(i, 11), vbLf)
  For j = 0 To t(i, 12)
    If IsDate(sA(j)) Then rest(n + j, 1) = CDate(sA(j)) Else rest(n + j, 1) = sA(j)
    rest(n + j, 2) = LTrim(sB(j)): rest(n + j, 3) = sC(j)
    rest(n + j, 5) = sE(j): rest(n + j, 9) = sI(j)
    If IsNumeric(sF(j)) Then rest(n + j, 6) = CDbl(sF(j)) Else rest(n + j, 6) = sF(j)
    If IsNumeric(sH(j)) Then rest(n + j, 8) = CDbl(sH(j)) Else rest(n + j, 8) = sH(j)
    If IsNumeric(sJ(j)) Then rest(n + j, 10) = CDbl(sJ(j)) Else rest(n + j, 10) = sJ(j)
    If IsNumeric(sK(j)) Then rest(n + j, 11) = CDbl(sK(j)) Else rest(n + j, 11) = sK(j)
  Next j
  n = n + j
  For j = 1 To 11
    If rest(n - 1, j) <> "" Then Exit For
  Next j
  If j = 12 Then n = n - 1 'suppression si la dernière ligne est vide
Next i
'---restitution---
[A1].Resize(UBound(rest), 11) = rest
Columns("A:K").AutoFit 'ajustement largeur
With Me.UsedRange: End With 'actualise la barre de défilement verticale
End Sub

Fichier (3).

La mise en forme des lignes de titres et des totaux est réalisée par une MFC à 2 conditions sur les colonnes A:K.

Edit 1 : j'avais complètement zappé la colonne J (Solde débit)...

Edit 2 : en B15 de la feuille "Original" il est évident qu'il manquait un "E" devant le dernier "ODcap".

Pour tester j'ai recopié le tableau source sur 15 000 lignes : chez moi la macro s'exécute en 4 secondes.

Avec le fichier (2) le même test a pris près de 10 minutes...

Bonne journée.

 

[job75]

Re,

Fichier (3 bis) si l'on veut supprimer toutes les lignes entièrement vides.

Sur 15 000 lignes la durée d'exécution est pratiquement inchangée, elle reste voisine de 4 secondes.

A+