Copier double ligne selon condition puis mettre nvell feuil
Bonjour à tous,
J'ai une feuille excel qui se présente comme suit (la mise en rouge c'est juste pour expliquer un cas):
1 NYN 0 0 0 0 0 0 0 3 0
1.1 KCA 1 0 0 1 0 2 0 0 x
2 TOR 2 0 0 1 0 0 0 2 0
2.1 TBA 0 0 1 0 0 0 0 0 2
3 LAN 2 0 1 0 0 5 3 4 0
3.1 SDN 0 0 0 0 0 0 0 0 0
4 CHN 0 0 4 0 0 0 2 0 0
4.1 ANA 0 0 0 0 0 1 0 0 0
5 BOS 0 0 2 0 0 2 0 0 2
5.1 CLE 0 0 0 2 0 0 0 0 0
6 NYN 0 0 0 2 0 0 0 0 0
6.1 KCA 0 0 0 0 0 0 0 0 0
La colonne A contient le numéro du match. L'équipe à domicile à un nombre entier et l'équipe à l'extérieur à le même nombre entier + 0.1.
Le but serai que pour chaque équipe, tout les scores des matchs (colonne C jusqu'à la dernière colonne qui n'est pas vide, cela varie selon les matchs) soit mis dans une nouvelle feuille qui porterait le nom de l'équipe. Exemple ici pour l'équipe "NYN". La feuille NYN aurait ceci (selon les données du haut) :
0 0 0 0 0 0 0 3 0 0 0 0 2 0 0 0 0 0
1 0 0 1 0 2 0 0 x 0 0 0 0 0 0 0 0 0
Avec en 1ère ligne les scores de NYN et en 2ème ligne les score de son adversaire.
Note : Lorsque NYN joue à l'extérieur, il a un nombre décimal. De ce fait, il se retrouve dans la ligne du bas dans les données mais il faudrait que son score même à l'extérieur se retrouve en 1ère ligne de la feuille NYN.
Merci de votre aide !
Cordialement,
Quik
Bonsoir à tous
quik09 : un début de réponse
A tester sur quelques lignes avec les cas présentés
Observe la variable w qui représentera le tableau restitué pour chacune de tes équipes.
Le paramètre unique de la propriété Item, c'est le nom de l'équipe soit la clé du dictionnaire
Cela risque d'être long, il faudra t'arranger pour éviter les ReDim Preserve
Option Explicit
Sub test()
Dim a, w(), i As Long, j As Long, e, dico As Object
Set dico = CreateObject("Scripting.Dictionary")
dico.comparemode = 1
a = Sheets("Tout_Les_Matchs").Range("a1").CurrentRegion.Value
'a = Sheets(1).Range("a1").CurrentRegion.Value
For i = 1 To UBound(a, 1) Step 2
If Not dico.exists(a(i, 2)) Then
ReDim w(1 To 2, 1 To UBound(a, 2) - 2)
Else
w = dico.Item(a(i, 2))
ReDim Preserve w(1 To 2, 1 To UBound(w, 2) + UBound(a, 2) - 2)
End If
For j = 3 To UBound(a, 2)
w(1, UBound(w, 2) - UBound(a, 2) + j) = a(i, j)
w(2, UBound(w, 2) - UBound(a, 2) + j) = a(i + 1, j)
Next
dico.Item(a(i, 2)) = w
If Not dico.exists(a(i + 1, 2)) Then
ReDim w(1 To 2, 1 To UBound(a, 2) - 2)
Else
w = dico.Item(a(i + 1, 2))
ReDim Preserve w(1 To 2, 1 To UBound(w, 2) + UBound(a, 2) - 2)
End If
For j = 3 To UBound(a, 2)
w(1, UBound(w, 2) - UBound(a, 2) + j) = a(i + 1, j)
w(2, UBound(w, 2) - UBound(a, 2) + j) = a(i, j)
Next
dico.Item(a(i + 1, 2)) = w
Next
'création des feuilles et
'restitution des données
For Each e In dico.keys
'''''
Next
End Subkilin89
Bonjour Quik,
n'oublie pas d'ajouter la référence à "Microsoft Scripting Runtime"
Option Explicit
Sub Transfert()
Dim team, sh, équipe As String, NoMatch As Double
Dim LastRw As Long, LastCol As Long, i As Long, y As Long, n As Long
Dim rw1 As Long, rw2 As Long, lig1 As Long, lig2 As Long
Dim Dico As New Scripting.Dictionary, Cle As String, valeur As String
Set sh = Sheets("Tout_Les_Matchs")
LastRw = sh.Cells(Rows.Count, 2).End(xlUp).Row
LastCol = sh.Cells.SpecialCells(xlCellTypeLastCell).Column
team = sh.Range("A1:B" & LastRw).Value
For y = LBound(team) To UBound(team)
Cle = team(y, 2)
valeur = ""
If Not Dico.Exists(Cle) Then
Dico.Add Cle, valeur
Sheets.Add After:=Sheets(Sheets.Count)
ActiveSheet.Name = Cle
End If
sh.Activate
Next y
For i = LBound(team) To UBound(team) Step 2
NoMatch = team(i, 1)
équipe = team(i, 2)
n = i
If NoMatch Mod 1 = 0 Then
rw1 = n
rw2 = n + 1
Else
rw1 = n - 1
rw2 = n
End If
lig1 = Sheets(équipe).Cells(Rows.Count, 1).End(xlUp).Row + 1
lig2 = lig1 + 1
Sheets(équipe).Range(Cells(lig1, 1).Address, Cells(lig2, LastCol).Address).Value = sh.Range(Cells(rw1, 1).Address, Cells(rw2, LastCol).Address).Value
Next i
Set sh = Nothing
End SubBonjour à tous !
Merci Klin89 pour ta réponse, j'ai mis la macro que tu as écrit dans excel puis je l'ai executé mais rien ne semble se passer... Je crois que je suis pas assez calé avec ces histoires de codes pour pouvoir l'adapter à mon fichier.
sabV merci également de ta réponse mais il y'a juste un seul souci, si tu va par exemple sur l'équipe NYN, seuls les match qu'ils ont joué à domicile (avec un nombre entier) sont mis dans la nouvelle feuille ! Si tu as une solution pour résoudre ça, c'est pas de refut !
Encore merci pour vos réponses
Bon après-midi
Quik
Re à tous,
Je pense déjà qu'il faut nettoyer ta feuille source avec cette macro
Sub nettoyage()
With ActiveSheet.UsedRange
.Value = Evaluate("if(row(" & .Address & "),clean(trim(" & .Address & ")))")
End With
End SubSelon ton exemple, il faut bien placer tes données l'une à coté des autres et non l'une en dessous des autres.
Il faut donc créer 30 feuilles, chacune d'entre elles contenant 2 lignes avec autant de colonnes dénombré ci-dessous.
sabV, comme le souligne quik09, il manque des lignes
Pour info, je n'ai pas beaucoup de temps à consacrer au forum en ce moment.
Edit : c'est normal que rien ne soit restitué, la dernière boucle est vide d'instructions
klin89
Re à tous !
Merci Klin89 pour ta proposition mais je pense qu'on y est presque avec celle de sabV. Je me suis rendu compte que tout bêtement en donnant un numéro unique à chaque match (lors de ce match, les deux équipes on le même numéro). Dans la liste le numéro est le même une fois avec le domicile en haut et une fois avec le domicile en bas. J'illustre mon propos :
Situation de base (l'équipe en haut est l'équipe qui joue à domicile)
1 NYN 0 0 0 0 0 0 0 3 0
1.1 KCA 1 0 0 1 0 2 0 0 x
Situation intermédiaire (l'équipe en haut est l'équipe qui joue à domicile)
1 NYN 0 0 0 0 0 0 0 3 0
1 KCA 1 0 0 1 0 2 0 0 x
Situation finale
1 KCA 1 0 0 1 0 2 0 0 x
1 NYN 0 0 0 0 0 0 0 3 0
1 NYN 0 0 0 0 0 0 0 3 0
1 KCA 1 0 0 1 0 2 0 0 x
De cette manière en appliquant la macro de sabV sur la "situation finale" (résultat en fichier joint) j'obtient (presque) ce que je veux ! Il me manque juste la mise en deux lignes des résulats. J'avais déjà posé la question pour une ligne et la solution fonctionne (https://forum.excel-pratique.com/post538258.html#p538258) peut-être qu'une simple modification de ce code peut permettre de mettre en deux !
Merci beaucoup de votre aide !
Quik
Bonjour Quik et Klin89,
Quik si j'ai bien compris, chacune des joutes doit se retrouver sur 2 onglets ?
par exemple pour la joute:
1 NYN
1.1 KCA
doit être transférer sur l'onglet NYN dans l'ordre
et elle doit être transférer sur l'onglet KCA dans l'ordre inverse ?
(Re) bonjour, Oui c'est exactement ça !
ok, c'est plus simple comme ça, pour le test j'ai mit la variable LastCol = 2 au lieu de
LastCol = sh.Cells.SpecialCells(xlCellTypeLastCell).ColumnOption Explicit
Sub Transfert()
Dim team, sh, équipe1 As String, équipe2 As String
Dim LastRw As Long, LastCol As Long, i As Long, y As Long, n As Long
Dim rw1 As Long, rw2 As Long, lig1 As Long, lig2 As Long
Dim Dico As New Scripting.Dictionary, Cle As String, valeur As String
Set sh = Sheets("Tout_Les_Matchs")
LastRw = sh.Cells(Rows.Count, 2).End(xlUp).Row
LastCol = 2 'sh.Cells.SpecialCells(xlCellTypeLastCell).Column -->pour le test LastCol = 2
team = sh.Range("A1:B" & LastRw).Value
For y = LBound(team) To UBound(team)
Cle = team(y, 2)
valeur = ""
If Not Dico.Exists(Cle) Then
Dico.Add Cle, valeur
Sheets.Add After:=Sheets(Sheets.Count)
ActiveSheet.Name = Cle
End If
sh.Activate
Next y
For i = LBound(team) To UBound(team) Step 2
équipe1 = team(i, 2)
équipe2 = team(i + 1, 2)
lig1 = Sheets(équipe1).Cells(Rows.Count, 1).End(xlUp).Row + 1
lig2 = Sheets(équipe2).Cells(Rows.Count, 1).End(xlUp).Row + 1
'transfert données sur 2 onglets
Sheets(équipe1).Range(Cells(lig1, 1).Address, Cells(lig1 + 1, LastCol).Address).Value = sh.Range(Cells(i, 1).Address, Cells(i + 1, LastCol).Address).Value
Sheets(équipe2).Range(Cells(lig2, 1).Address, Cells(lig2, LastCol).Address).Value = sh.Range(Cells(i + 1, 1).Address, Cells(i + 1, LastCol).Address).Value
Sheets(équipe2).Range(Cells(lig2 + 1, 1).Address, Cells(lig2 + 1, LastCol).Address).Value = sh.Range(Cells(i, 1).Address, Cells(i, LastCol).Address).Value
Next i
Set sh = Nothing
End SubBonsoir !
Tu es un vrai fou ! ça fonctionne nickel ! Il reste juste à mettre tout les résultats de chaque équipe sur 2 lignes. J'avais déjà demandé pour une ligne (https://forum.excel-pratique.com/post538258.html#p538258) donc je pense qu'une petite retouche du code déjà fait suffit pour terminer le travail ! (si tu en a marre tu peux le dire xD)
Merci pour tout ce que tu as déjà fait
Bonne soirée
Quik
pour avoir tous les résultats, il suffit de remplacer la ligne
LastCol = 2par
LastCol = sh.Cells.SpecialCells(xlCellTypeLastCell).ColumnOui ça c'est tout bon (encore merci!) mais après j'aimerai mettre les resultats de chaque équipe en deux lignes. La première ligne ce sont les résultats de l'équipe et la deuxième ligne les résultats de l'équipe adverse. Actuellement avec ta solution, j'ai cela (exemple pour l'équipe NYN) :
1 NYN 0 0 0 0 0 0 0 3 0
1.1 KCA 1 0 0 1 0 2 0 0 x
16 NYN 0 0 0 2 0 0 0 0 0
16.1 KCA 0 0 0 0 0 0 0 0 0
ce que j'aimerai c'est cela :
1 NYN 0 0 0 0 0 0 0 3 0 0 0 0 2 0 0 0 0
1.1 KCA 1 0 0 1 0 2 0 0 x 0 0 0 0 0 0 0 0
Vois-tu ce que je veux dire ?
Quik
Re quik09,
Essaie ceci, tu peux aller voter en attendant
J'ai effectué un nettoyage de tes données avec la macro précédememnt éditée.
Option Explicit
Sub test()
Dim a, w(), x(),nCols As Byte, i As Long, ii As Long, e
Dim dico As Scripting.Dictionary
Set dico = New Scripting.Dictionary
dico.comparemode = 1
'a = Sheets("Tout_Les_Matchs").Range("a1").CurrentRegion.Value
a = Sheets(1).Range("a1").CurrentRegion.Value
For i = 1 To UBound(a, 1)
If Application.CountA(Application.Index(a, i, 0)) > 2 Then
If Not dico.exists(a(i, 2)) Then
ReDim w(1 To 2)
w(1) = Empty
Else
w = dico.Item(a(i, 2))
End If
w(2) = w(2) + Application.CountA(Application.Index(a, i, 0)) - 2
dico.Item(a(i, 2)) = w
End If
Next
For i = 1 To UBound(a, 1)
If dico.exists(a(i, 2)) Then
w = dico.Item(a(i, 2))
If IsEmpty(w(1)) Then
ReDim x(1 To 2, 1 To w(2))
Else
x = w(2)
End If
nCols = Application.CountA(Application.Index(a, i, 0)) - 2
w(1) = w(1) + nCols
For ii = 1 To nCols
x(1, w(1) - nCols + ii) = a(i, ii + 2)
Next
If i Mod 2 <> 0 Then
For ii = 1 To nCols
x(2, w(1) - nCols + ii) = a(i + 1, ii + 2)
Next
Else
For ii = 1 To nCols
x(2, w(1) - nCols + ii) = a(i - 1, ii + 2)
Next
End If
w(2) = x
dico.Item(a(i, 2)) = w
End If
Next
Application.ScreenUpdating = False
For Each e In dico.keys
If Not IsSheetExists(e) Then
Sheets.Add(after:=Sheets(Sheets.Count)).Name = e
End If
Sheets(e).Cells.Clear
With Sheets(e).Cells(1).Resize(UBound(dico.Item(e)(2), 1), UBound(dico.Item(e)(2), 2))
.Value = dico.Item(e)(2)
.Font.Name = "calibri"
.Font.Size = 10
.BorderAround Weight:=xlThin
.Borders(xlInsideVertical).Weight = xlThin
.VerticalAlignment = xlCenter
.HorizontalAlignment = xlCenter
End With
Next
Set dico = Nothing
Application.ScreenUpdating = True
End SubFunction IsSheetExists(ByVal sn As String) As Boolean
On Error Resume Next
IsSheetExists = Len(Sheets(sn).Name)
On Error GoTo 0
End Functionklin89
Re,
Au final, on va faire plus court.
J'ai fixé les dimensions de la variable X en dur en m'appuyant sur le nombre de colonnes calculé pour chacune des équipes
voir l'image jointe précédemment.
Option Explicit
Sub test()
Dim a, w(), x(),nCols As Byte, i As Long, ii As Long, e
Dim dico As Scripting.Dictionary
Set dico = New Scripting.Dictionary
dico.comparemode = 1
'a = Sheets("Tout_Les_Matchs").Range("a1").CurrentRegion.Value
a = Sheets(1).Range("a1").CurrentRegion.Value
For i = 1 To UBound(a, 1)
If Application.CountA(Application.Index(a, i, 0)) > 2 Then
If Not dico.exists(a(i, 2)) Then
ReDim w(1 To 2)
ReDim x(1 To 2, 1 To 1510)
Else
w = dico.Item(a(i, 2))
x = w(2)
End If
nCols = Application.CountA(Application.Index(a, i, 0)) - 2
w(1) = w(1) + nCols
For ii = 1 To nCols
x(1, w(1) - nCols + ii) = a(i, ii + 2)
Next
If i Mod 2 <> 0 Then
For ii = 1 To nCols
x(2, w(1) - nCols + ii) = a(i + 1, ii + 2)
Next
Else
For ii = 1 To nCols
x(2, w(1) - nCols + ii) = a(i - 1, ii + 2)
Next
End If
w(2) = x
dico.Item(a(i, 2)) = w
End If
Next
Application.ScreenUpdating = False
For Each e In dico.keys
If Not IsSheetExists(e) Then
Sheets.Add(after:=Sheets(Sheets.Count)).Name = e
End If
Sheets(e).Cells.Clear
With Sheets(e).Cells(1).Resize(UBound(dico.Item(e)(2), 1), UBound(dico.Item(e)(2), 2))
.Value = dico.Item(e)(2)
With .CurrentRegion
.Font.Name = "calibri"
.Font.Size = 10
.BorderAround Weight:=xlThin
.Borders(xlInsideVertical).Weight = xlThin
.VerticalAlignment = xlCenter
.HorizontalAlignment = xlCenter
End With
End With
Next
Set dico = Nothing
Application.ScreenUpdating = True
End SubFunction IsSheetExists(ByVal sn As String) As Boolean
On Error Resume Next
IsSheetExists = Len(Sheets(sn).Name)
On Error GoTo 0
End Functionklin89
Oui ça c'est tout bon (encore merci!) mais après j'aimerai mettre les resultats de chaque équipe en deux lignes. La première ligne ce sont les résultats de l'équipe et la deuxième ligne les résultats de l'équipe adverse. Actuellement avec ta solution, j'ai cela (exemple pour l'équipe NYN) :
1 NYN 0 0 0 0 0 0 0 3 0
1.1 KCA 1 0 0 1 0 2 0 0 x
16 NYN 0 0 0 2 0 0 0 0 0
16.1 KCA 0 0 0 0 0 0 0 0 0
ce que j'aimerai c'est cela :
1 NYN 0 0 0 0 0 0 0 3 0 0 0 0 2 0 0 0 0
1.1 KCA 1 0 0 1 0 2 0 0 x 0 0 0 0 0 0 0 0
donc pour NYN - PHI il y a 19 joutes,
donc 18 lignes de données à ramener au bout de la première ligne de NYN
et 18 lignes de données à ramener au bout de la première ligne de PHI
c'est bien ça ?
Est-ce que la dernière colonne de l'onglet "Tout_Les_Matchs" est bien la colonne AJ ?
Bonjour à tous,
Oui sabV, la dernière colonne est bien AJ. Pour l'explication je crois que je ne me suis pas bien fait comprendre alors je te met un fichier joint avec des couleurs pour bien expliquer le but. En gros si les ligne sont numéroté comme suit:
1
2
3
4
5
6
7
8
9
10
11
12
13
14
il faut coller (sans le nom des équipe, juste les scores) 3 à la suite de 1, 4 à la suite de 2, 5 à la suite de 3, 6 à la suite de 4.
1 3 5 7 9 11 13
2 4 6 8 1012 14
J'espère que tu as compris mais encore une fois, je me répète, ça a déjà été fais pour tout mettre sur une seule ligne (https://forum.excel-pratique.com/post538163.html#p538163), je pense que comme tu est calé en code, une simple manipulation du code existant et le tour est joué !
Merci pour ton aide !
Bon après-midi
Quik
Re et re quik09,
Dernière version, c'est nettement plus rapide
Option Explicit
Sub test()
Dim a, w(), x(), i As Long, ii As Long, e, dico As Object
Dim dLig As Long, lig As Long, dCol As Byte, nCols As Byte
Set dico = CreateObject("Scripting.Dictionary")
dico.comparemode = 1
With Sheets("Tout_Les_Matchs")
dLig = .Range("A" & .Rows.Count).End(xlUp).Row
For lig = 1 To dLig Step 2
dCol = .Range("A" & lig).End(xlToRight).Column
If dCol > 2 Then
a = .Range(.Cells(lig, 1), .Cells(lig + 1, dCol))
For i = 1 To UBound(a, 1)
If Not dico.exists(a(i, 2)) Then
ReDim w(1 To 2)
ReDim x(1 To 2, 1 To 1510)
Else
w = dico.Item(a(i, 2))
x = w(2)
End If
nCols = UBound(a, 2) - 2
w(1) = w(1) + nCols
For ii = 1 To nCols
x(1, w(1) - nCols + ii) = a(i, ii + 2)
If i = 1 Then
x(2, w(1) - nCols + ii) = a(i + 1, ii + 2)
Else
x(2, w(1) - nCols + ii) = a(i - 1, ii + 2)
End If
Next
w(2) = x
dico.Item(a(i, 2)) = w
Next
End If
Next
End With
Application.ScreenUpdating = False
For Each e In dico.keys
If Not IsSheetExists(e) Then
Sheets.Add(after:=Sheets(Sheets.Count)).Name = e
End If
Sheets(e).Cells.Clear
With Sheets(e).Cells(1).Resize(UBound(dico.Item(e)(2), 1), UBound(dico.Item(e)(2), 2))
.Value = dico.Item(e)(2)
With .CurrentRegion
.Font.Name = "calibri"
.Font.Size = 10
.BorderAround Weight:=xlThin
.Borders(xlInsideVertical).Weight = xlThin
.VerticalAlignment = xlCenter
.HorizontalAlignment = xlCenter
End With
End With
Next
Set dico = Nothing
Application.ScreenUpdating = True
End SubFunction IsSheetExists(ByVal sn As String) As Boolean
On Error Resume Next
IsSheetExists = Len(Sheets(sn).Name)
On Error GoTo 0
End Functionklin89
Re re re re re re re re Klin89 !
Alors j'ai mis ta dernière macro mais il y a une erreur qui apparaît
Saurai-tu savoir d'où elle vient ?
merci !!
Quik
Re,
Sur le fichier du post #1, après application de la macro de nettoyage, ça fonctionne
Tu as dû tester sur un fichier dont la structure des données a changé. 8)
Envoie ton fichier en privé que je teste, je ne peux rien faire en la circonstance
C'est peut-être la 2ème dimension de x qui fait planter
Essaie avec un indice supérieur
ReDim x(1 To 2, 1 To 1510)
klin89
Re !
ça fonctionne parfaitement !!!!!!!!!!! YOuhou !! (J'avais pas appliqué la macro de nettoyage c'est pour ça que ça ne fonctionnait pas !)
Merci beaucoup de ton aide ! et de celle de sabV !
Bon après-midi
Quik