Resolu

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
job75

job75

XLDnaute Barbatruc
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

  • Dispacher-de-la-feuil1-vers-different-onglets-pronos-du12.03.2016.Complet(3).xls
    221 KB · Affichages: 51
Vote positif 0 Vote négatif
Guido

Guido

XLDnaute Accro
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

  • TABLEAUX DES COURSES TRANSFEREES 2016.xls
    272 KB · Affichages: 43
Vote positif 0 Vote négatif
job75

job75

XLDnaute Barbatruc
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

  • TABLEAUX DES COURSES TRANSFEREES 2016(1).xls
    252 KB · Affichages: 43
Vote positif 0 Vote négatif
Guido

Guido

XLDnaute Accro
Re : Garder seulement une partie d'une phrase......

Re

Bonsoir job75 et le Forum

Un grand MERCI a Toi job75 pour la finalisation de ce fichier..Merci.

il va me facilité la vie au quotidien.

Bonne soiree

Amitiés

Guido
 
Vote positif 0 Vote négatif
job75

job75

XLDnaute Barbatruc
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

  • TABLEAUX DES COURSES TRANSFEREES 2016(2).xls
    249 KB · Affichages: 30
Dernière édition:
Vote positif 0 Vote négatif
Guido

Guido

XLDnaute Accro
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
job75

job75

XLDnaute Barbatruc
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

  • TABLEAUX DES COURSES TRANSFEREES 2016(3).xls
    250.5 KB · Affichages: 38
Vote positif 0 Vote négatif
Guido

Guido

XLDnaute Accro
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
Guido

Guido

XLDnaute Accro
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: 27
  • Capture.PNG
    Capture.PNG
    31.6 KB · Affichages: 41
Vote positif 0 Vote négatif
job75

job75

XLDnaute Barbatruc
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

  • TABLEAUX DES COURSES TRANSFEREES 2016(4).xls
    252 KB · Affichages: 37
Dernière édition:
Vote positif 0 Vote négatif

Discussions similaires

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

Membres actuellement en ligne

10 membres et 129 invités.

Partager cette page

Tutos vidéos

Power Query : Ajouter des requêtes (Excel et Power BI)
Créez votre première fonction LAMBDA dans Excel en 3 étapes!
LAMBDA, l’arme secrète de Microsoft pour Excel !
Office Insider - Découvrez les nouveautés Excel avant tout le monde

Statistiques des forums

Discussions
314 162
Messages
2 106 601
Membres
109 637
dernier inscrit
lafforest