Resolu

Créer une discussion
Répondre
  • Initiateur de la discussion Initiateur de la discussion Guido
  • Date de début Date de début

Boostez vos compétences Excel avec notre communauté !

Rejoignez Excel Downloads, le rendez-vous des passionnés où l'entraide fait la force. Apprenez, échangez, progressez – et tout ça gratuitement ! 👉 Inscrivez-vous maintenant !

S'inscrire
Guido

Guido

XLDnaute Accro
Bonjour le forum

J'aimerais garder seulement une partie d'une phrase

Course: R.1-C.7 Hippodrome: SAINT-CLOUD Allocation: 16000 € Discipline: PLAT Spécialité: RECLAMER

Course: R.1-C.7

Course: R.3-C.2 Hippodrome: CAEN Allocation: 19000 € Discipline: ATTELE

Course: R.3-C.2

Ses entetes se trouvent dans une feuille excel en colonne B et toutes les 20 lignes environs mais max sur 1000 lignes

Merci pour votre aide

Guido
 
Trier par date Trier par votes
Re : Garder seulement une partie d'une phrase......

Bonjour Guido, le forum,

Si l'on veut une seule ligne vide pour séparer les tableaux, le code de la feuille "Prono" :

Code: 
Private Sub Worksheet_Deactivate()
Dim i&, j&
Application.ScreenUpdating = False
For i = Cells(Rows.Count, 2).End(xlUp).Row To 1 Step -1
  If Cells(i, 2) Like "Course*" Then
    With Range(Cells(i, 1), Cells(i + 6, 2).CurrentRegion)
      For j = .Rows.Count + 4 To .Rows.Count + 2 Step -1
        If .Cells(j, 2) = "" Then .Rows(j).EntireRow.Delete
      Next j
    End With
  End If
Next i
With Me.UsedRange: End With 'actualise la barre de défilement
End Sub
Et dans Workbook_SheetActivate :

Code: 
'---
        With .Range(.Cells(i, 2), .Cells(i + 6, 2).CurrentRegion)
          .Resize(.Rows.Count + 1).EntireRow.Delete
        End With
Fichier (3).

A+
 

Pièces jointes

Vote positif 0 Vote négatif
Re : Garder seulement une partie d'une phrase......

Re

Bonsoir job75 et le forum

La feuille Prono change tous les jours de formes... chevaux et cotes,ect.

C'est pour cela que je cherche a transferer les plages dans un modele unique ( de plage soit max 20 partant.)

Je vous donne le fichier pour 5 Reunions.

Merci pour votre aide,car je ne sais pas faire

Amitiés

Guido
 

Pièces jointes

Vote positif 0 Vote négatif
Re : Garder seulement une partie d'une phrase......

Bonjour Guido,

Voyez ce fichier et la macro :

Code: 
Private Sub Workbook_SheetActivate(ByVal Sh As Object)
Dim F As Worksheet, lig&, x$, i&, P As Range, j As Byte, k As Variant
Set F = Feuil2 'CodeNme
With Sh
  If .Name Like "TAB R#*" Then
    Application.ScreenUpdating = False
    .Cells.Clear 'RAZ
    lig = 1
    x = "Course: R." & Val(Mid(.Name, 6)) & "-*"
    For i = 1 To F.Cells(.Rows.Count, 2).End(xlUp).Row
      If F.Cells(i, 2) Like x Then
        Set P = F.Range(F.Cells(i, 1), F.Cells(i + 6, 2).CurrentRegion)
        P.Rows("1:8").Copy .Cells(lig, 1) 'début
        P.Rows(P.Rows.Count - 9).Resize(10).Copy .Cells(lig + 28, 1) 'fin
        For j = 1 To 20 'milieu
          k = Application.Match(j, P.Columns(2), 0)
          If IsNumeric(k) Then P.Rows(k).Copy .Cells(lig + j + 7, 1)
          .Cells(lig + j + 7, 1) = j
        Next
        '---mises en forme---
        .Cells(lig, 2).Resize(38, P.Columns.Count - 1).Borders.Weight = xlMedium
        With .Cells(lig + 8, 1).Resize(20)
          .Borders.Weight = xlThin
          .Interior.ColorIndex = 16 'gris
          .Font.ColorIndex = 6 'jaune
          .HorizontalAlignment = xlCenter
        End With
        lig = lig + 38
      End If
    Next i
  End If
  ActiveCell.Select
  With .UsedRange: End With 'actualise la barre de défilement
End With
End Sub
Bonne soirée.
 

Pièces jointes

Vote positif 0 Vote négatif
Re : Garder seulement une partie d'une phrase......

Bonjour Guido, le forum,

Cette manière de faire est plus logique (pas de Application.Match) et un peu plus rapide :

Code: 
Private Sub Workbook_SheetActivate(ByVal Sh As Object)
Dim F As Worksheet, i&, lig&, x$, P As Range, j As Byte
Set F = Feuil2 'CodeNme
With Sh
  If .Name Like "TAB R#*" Then
    Application.ScreenUpdating = False
    .Cells.Clear 'RAZ
    i = Application.CountIf(F.Columns(2), ">20")
    If i Then MsgBox i & " numéro(s) au delà de 20 en colonne B...": Exit Sub
    lig = 1
    x = "Course: R." & Val(Mid(.Name, 6)) & "-*"
    For i = 1 To F.Cells(.Rows.Count, 2).End(xlUp).Row
      If F.Cells(i, 2) Like x Then
        Set P = F.Range(F.Cells(i, 1), F.Cells(i + 6, 2).CurrentRegion)
        P.Rows("1:8").Copy .Cells(lig, 1) 'début
        P.Rows(P.Rows.Count - 9).Resize(10).Copy .Cells(lig + 28, 1) 'fin
        For j = 9 To P.Rows.Count - 10 'milieu
          If Val(P(j, 2)) > 0 Then P.Rows(j).Copy .Cells(lig + P(j, 2) + 7, 1)
        Next
        .Cells(lig, 2).Resize(38, P.Columns.Count - 1).Borders.Weight = xlThin
        If lig = 1 Then
          '---mises en forme de la 1ère colonne---
          With .Cells(lig + 8, 1).Resize(20)
            .Cells(1) = 1
            .DataSeries
            .Borders.Weight = xlThin
            .Interior.ColorIndex = 16 'gris
            .Font.ColorIndex = 6 'jaune
            .HorizontalAlignment = xlCenter
          End With
        Else
          .Cells(9, 1).Resize(20).Copy .Cells(lig + 8, 1)
        End If
        lig = lig + 38
      End If
    Next i
  End If
  ActiveCell.Select
  With .UsedRange: End With 'actualise la barre de défilement
End With
End Sub
Edit : j'ai mis un message de contrôle au début.

Fichier (2).

Bonne journée.
 

Pièces jointes

Dernière édition:
Vote positif 0 Vote négatif
Re : Garder seulement une partie d'une phrase......

Re

Bonjour job75 et le Forum

Merci pour le fichier.

Une demande si c possible?

j'aimerais crée une macro qui transforment les virgules, en point ...dans les coll D et E ,et ensuite que

les cellules qui se trouvent dans la col C sous le mot Fav soit 20 cellules soit remplacer par les résultats

de la soustractions D9-E9 ..ainsi de suite .

Meri d'avance

Guido
 
Vote positif 0 Vote négatif
Re : Garder seulement une partie d'une phrase......

Re,

Voici :

Code: 
Private Sub Workbook_SheetActivate(ByVal Sh As Object)
Dim F As Worksheet, i&, lig&, x$, P As Range, j As Byte, n&, n1, n2
Set F = Feuil2 'CodeNme
With Sh
  If .Name Like "TAB R#*" Then
    Application.ScreenUpdating = False
    .Cells.Clear 'RAZ
    i = Application.CountIf(F.Columns(2), ">20")
    If i Then MsgBox i & " numéro(s) au delà de 20 en colonne B...": Exit Sub
    lig = 1
    x = "Course: R." & Val(Mid(.Name, 6)) & "-*"
    For i = 1 To F.Cells(.Rows.Count, 2).End(xlUp).Row
      If F.Cells(i, 2) Like x Then
        Set P = F.Range(F.Cells(i, 1), F.Cells(i + 6, 2).CurrentRegion)
        P.Rows("1:8").Copy .Cells(lig, 1) 'début
        P.Rows(P.Rows.Count - 9).Resize(10).Copy .Cells(lig + 28, 1) 'fin
        For j = 9 To P.Rows.Count - 10 'milieu
          n = lig + Val(P(j, 2)) + 7
          If n > lig + 7 Then
            n1 = Val(Replace(P(j, 4), ",", "."))
            n2 = Val(Replace(P(j, 5), ",", "."))
            P.Rows(j).Copy .Cells(n, 1)
            .Cells(n, 3) = n1 - n2
            .Cells(n, 4) = n1
            .Cells(n, 5) = n2
          End If
        Next
        .Cells(lig, 2).Resize(38, P.Columns.Count - 1).Borders.Weight = xlThin
        If lig = 1 Then
          '---mises en forme de la 1ère colonne---
          With .Cells(lig + 8, 1).Resize(20)
            .Cells(1) = 1
            .DataSeries
            .Borders.Weight = xlThin
            .Interior.ColorIndex = 16 'gris
            .Font.ColorIndex = 6 'jaune
            .HorizontalAlignment = xlCenter
          End With
        Else
          .Cells(9, 1).Resize(20).Copy .Cells(lig + 8, 1)
        End If
        lig = lig + 38
      End If
    Next i
  End If
  ActiveCell.Select
  With .UsedRange: End With 'actualise la barre de défilement
End With
End Sub
Fichier (3).

A+
 

Pièces jointes

Vote positif 0 Vote négatif
Re : Garder seulement une partie d'une phrase......

Re

Bonjour job75 et le Forum

Merci pour le fichier avec cette nouvelle fonction.

cela me permet d'eviter des boutons de macros et autres formules.

L'ancien fichier pesais 25 417 Ko....

Donc encore Merci job 75

Amitiés a bientôt..

Guido
 
Vote positif 0 Vote négatif
Re : Garder seulement une partie d'une phrase......

Bonsoir le forum


Apres avoir inserer une MFC dans le fichier ,quand je passe d'un onglet a l'autre la MFC disparais ou s'anule

est til possibles d'integré dans les macros cette MFC.

Merci

Guido
 

Pièces jointes

  • Capture.PNG
    Capture.PNG
    31.6 KB · Affichages: 32
  • Capture.PNG
    Capture.PNG
    31.6 KB · Affichages: 46
Vote positif 0 Vote négatif
Re : Garder seulement une partie d'une phrase......

Bonjour Guido, le forum,

Guido à dit:
J'ai meme essayer de faire afficher le 1er plus petit moins et le 1er plus petit positif (...)
Cliquez pour agrandir...

Je suppose qu'il s'agit de la colonne C, alors avec 2 cellules à colorer c'est jouable.

Les variables pn et pp déterminent les cellules à colorer :

Code: 
Private Sub Workbook_SheetActivate(ByVal Sh As Object)
Dim F As Worksheet, i&, lig&, x$, P As Range
Dim pn As Range, pp As Range, j As Byte, n&, n1, n2
Set F = Feuil2 'CodeNme
With Sh
  If .Name Like "TAB R#*" Then
    Application.ScreenUpdating = False
    .Cells.Clear 'RAZ
    i = Application.CountIf(F.Columns(2), ">20")
    If i Then MsgBox i & " numéro(s) au delà de 20 en colonne B...": Exit Sub
    lig = 1
    x = "Course: R." & Val(Mid(.Name, 6)) & "-*"
    For i = 1 To F.Cells(.Rows.Count, 2).End(xlUp).Row
      If F.Cells(i, 2) Like x Then
        Set P = F.Range(F.Cells(i, 1), F.Cells(i + 6, 2).CurrentRegion)
        P.Rows("1:8").Copy .Cells(lig, 1) 'début
        P.Rows(P.Rows.Count - 9).Resize(10).Copy .Cells(lig + 28, 1) 'fin
        Set pn = Nothing 'premier plus petit négatif (en valeur absolue)
        Set pp = Nothing 'premier plus petit positif
        For j = 9 To P.Rows.Count - 10 'milieu
          n = lig + Val(P(j, 2)) + 7
          If n > lig + 7 Then
            n1 = Val(Replace(P(j, 4), ",", "."))
            n2 = Val(Replace(P(j, 5), ",", "."))
            P.Rows(j).Copy .Cells(n, 1)
            .Cells(n, 3) = n1 - n2
            .Cells(n, 4) = n1
            .Cells(n, 5) = n2
            If pn Is Nothing And n1 - n2 < 0 Then Set pn = .Cells(n, 3)
            If pp Is Nothing And n1 - n2 >= 0 Then Set pp = .Cells(n, 3)
            If Not pn Is Nothing And n1 - n2 < 0 Then _
              If n1 - n2 > pn Then Set pn = .Cells(n, 3)
            If Not pp Is Nothing And n1 - n2 >= 0 Then _
              If n1 - n2 < pp Then Set pp = .Cells(n, 3)
          End If
        Next j
        '---pn et pp en colonne C---
        .Cells(lig + 8, 3).Resize(20).Interior.ColorIndex = xlNone 'RAZ
        .Cells(lig + 8, 3).Resize(20).Font.ColorIndex = xlAutomatic 'RAZ
        If Not pn Is Nothing Then _
          pn.Interior.ColorIndex = 3: pn.Font.ColorIndex = 6
        If Not pp Is Nothing Then _
          pp.Interior.ColorIndex = 49: pp.Font.ColorIndex = 6
        '---bordures---
        .Cells(lig, 2).Resize(38, P.Columns.Count - 1).Borders.Weight = xlThin
        If lig = 1 Then
          '---mises en forme de la 1ère colonne---
          With .Cells(lig + 8, 1).Resize(20)
            .Cells(1) = 1
            .DataSeries
            .Borders.Weight = xlThin
            .Interior.ColorIndex = 16 'gris
            .Font.ColorIndex = 6 'jaune
            .HorizontalAlignment = xlCenter
          End With
        Else
          .Cells(9, 1).Resize(20).Copy .Cells(lig + 8, 1)
        End If
        lig = lig + 38
      End If
    Next i
  End If
  ActiveCell.Select
  With .UsedRange: End With 'actualise la barre de défilement
End With
End Sub
Evidemment l'exécution de la macro prend plus de temps [Edit] non en fait pratiquement pas.

Fichier (4).

Bonne journée.
 

Pièces jointes

Dernière édition:
Vote positif 0 Vote négatif
Rejoins nos membres "Supporter XLD" et booste ton expérience Excel !
- Navigue sans publicité
- Accède à Cléa, notre assistante IA experte Excel... et pas que...
- Profite de fonctionnalités exclusives
Ton soutien permet à Excel Downloads de rester 100% gratuit et de continuer à rassembler les passionnés d'Excel.
Je deviens Supporter XLD

Discussions similaires

Guido
  • Question Question
[ Resolu par zebanx, eddy1945 ] Garder une partie d'un titre et lui atribué une valeur..
Réponses
10
Affichages
1 K
Guido
Guido
Guido
  • Question Question
[ RESOLU ] Modifier une macro,qui suppriment des plage...
Réponses
12
Affichages
2 K
job75
job75
J
  • Question Question
plus c est long plus c est bon
Réponses
4
Affichages
1 K
jeannot68
J
Retour