Code VBA qui ne fonctionne pas bien
Bonjour à tous,
Ça m'embête d'écrire ce message.
Un de vos collègue m'a fourni un code VBA qui fonctionne très bien dans le mini fichier que j'ai attaché en pièce jointe lors de ma demande. Le problème c'est qu'il ne fonctionne pas bien dans mon fichier principale qui est beaucoup plus volumineux. J'ai demandé è votre collègue s'il pouvait m'aider mais il m'a recommandé de retourner sur le forum car j'avais modifié son code et qu'il ne comprenait pas trop ce dont j'avais besoin. C'est vrai que j'ai modifié le code, seulement pour l'adapté à mon fichier principale en ajoutant quelques lignes et en modifiant quelques valeurs mais sans jamais toucher à la base du code. Je n'ai pas les connaissances nécessaire pour changer un code à sa base. C'est pourquoi j'utilise le forum qui m'aide beaucoup. C'est la seule façon que j'ai d'apprendre.
J'utilise le forum depuis 2013 et j'ai toujours respecté les utilisateurs et les intervenants.
Mon problème est que certaines données ne vont pas à la bonne personne lors du deuxième transfert à partir des semaines. Même si je commence le transfert à partir de la Sem.10, le premier transfert se fait bien mais le deuxième accroche.
Après 2 transfert chacun des joueurs devrait avoir 6 parties de jouer. Le problème est que certain joueur en ont 9 alors que d'autres en ont 3.
J'ai fait un code de couleur afin de montrer qui reçoit les données de qui.
Merci beaucoup à l'avance de votre aide.
bonjour golfeur01
Vous avez changer le A par I :
Set T = Worksheets("Données").Range("A2:I1003").Find(sh_source.Range("B" & J).Value)le code correcte est :
Set T = Worksheets("Données").Range("A2:A1003").Find(sh_source.Range("B" & J).Value)Alors si vous voulez gardez le code non complet il suffit de changer le " I " par " A "
Pour le code d aujourd’hui est le dernier code qui a bien fonctionne, il créera des feuilles de semaines automatiquement, si vous rencontrai un problème avec la création automatique des feuilles de semaines donc reposter comme suit :
Titre : Code vba + copier de feuilles + personnalisée
Et expliquer aux membres ce que vous voulez laisser sur la feuille crée et ce que vous voulez l effacer Comme ca vous n’aurez pas besoin de créer la feuille de nouvelle semaine manuellement.
SVP ressayer mon fichier joint
Option Explicit
Dim sh_distan As Worksheet, sh_source As Worksheet
Private Sub Test_Onglet()
On Error Resume Next
Err = 0
sh_source.Copy After:=sh_source
If sh_source.Name = "Abat-Neuf" Then
ActiveSheet.Name = "Sem.01"
ElseIf Not sh_source.Name = "Abat-Neuf" And Not sh_source.Name = "Données" Then ' si vous ajouter une fuille a jouter ici!
If Val(Mid(ActiveSheet.Name, 5)) < 9 Then
ActiveSheet.Name = "Sem.0" & (Val(Mid(sh_source.Name, 5)) + 1)
ElseIf Val(Mid(ActiveSheet.Name, 5)) >= 9 Then
ActiveSheet.Name = "Sem." & (Val(Mid(sh_source.Name, 5)) + 1)
End If
End If
If Err <> 0 Then
Application.DisplayAlerts = False
ActiveSheet.Delete 'détruit la feuille créée
Application.DisplayAlerts = True
End If
End Sub
Sub standar()
Dim T
Dim i As Integer, j As Integer
Dim DERL_SO As Integer, DERL_DO As Integer
Application.ScreenUpdating = False
' "Sem.01" >>>> "Sem.09" >>>> "Sem.10">>>> "Sem.15" .........
If ActiveSheet.Name = "Abat-Neuf" Then
Set sh_source = Worksheets("Abat-Neuf") ' A la place de sh_source = "Abat-Neuf"
Call Test_Onglet
Set sh_distan = Worksheets("Sem.01") 'A la place desh_distan = "Sem.01"
sh_distan.Range("A1").Value = sh_distan.Name
' sh_distan.Range("B2:B160").Value = sh_source.Range("B2:B160").Value
ElseIf Not ActiveSheet.Name = "Abat-Neuf" And Not ActiveSheet.Name = "Données" Then ' si vous ajouter une fuille a jouter ici!
If Val(Mid(ActiveSheet.Name, 5)) < 9 Then ' 4 parsque vous aver que 4 semaine encore
Set sh_source = Worksheets(ActiveSheet.Name) ' A la place de sh_source = "Abat-Neuf"
Call Test_Onglet
Set sh_distan = Worksheets("Sem.0" & (Val(Mid(sh_source.Name, 5)) + 1))
sh_distan.Range("A1").Value = sh_distan.Name
' sh_distan.Range("B2:B160").Value = sh_source.Range("B2:B160").Value
ElseIf Val(Mid(ActiveSheet.Name, 5)) >= 9 Then
Set sh_source = Worksheets(ActiveSheet.Name)
Call Test_Onglet
Set sh_distan = Worksheets("Sem." & (Val(Mid(sh_source.Name, 5)) + 1))
sh_distan.Range("A1").Value = sh_distan.Name
' sh_distan.Range("B2:B160").Value = sh_source.Range("B2:B160").Value
End If
End If
If Not sh_source Is Nothing Then
DERL_SO = sh_source.Range("B" & Rows.Count).End(xlUp).Row
DERL_DO = Worksheets("Données").Range("A" & Rows.Count).End(xlUp).Row
For j = 2 To DERL_SO
If sh_source.Range("B" & j).Value <> "" Then
Set T = Worksheets("Données").Range("A2:A" & DERL_DO).Find(sh_source.Range("B" & j).Value)
If Not T Is Nothing Then
With Worksheets("Données")
' .Range("F" & T.Row).Value = sh_source.Range("d" & j).Value
.Range("G" & T.Row).Value = .Range("G" & T.Row).Value + sh_source.Range("M" & j).Value
.Range("H" & T.Row).Value = .Range("H" & T.Row).Value + sh_source.Range("N" & j).Value
' .Range("G" & T.Row).Value = sh_source.Range("O" & j).Value
' .Range("H" & T.Row).Value = sh_source.Range("P" & j).Value
End With
End If
End If
Next
End If
' If Not sh_source Is Nothing Then
' For i = 0 To 10
' sh_source.Range("E" & 2 + (10 * i) & ":L" & 10 + (10 * i)).ClearContents
' sh_source.Range("E" & 7 + (1 * i) & ":L" & 8 + (1 * i)).ClearContents
' Next
' End If
If Not sh_distan Is Nothing Then
For i = 0 To 10
sh_distan.Range("E" & 2 + (10 * i) & ":L" & 10 + (10 * i)).ClearContents
sh_distan.Range("E" & 7 + (1 * i) & ":L" & 8 + (1 * i)).ClearContents
Next
sh_distan.Activate
End If
Application.ScreenUpdating = True
End SubBonsoir Amir,
Tu es mon sauveur. Merci...Merci....
Ton code fonctionne parfaitement en changeant le I par le A.
Je ne peux pas utiliser ton autre code car à chaque semaine j'ai des information qui sont uniques à chacune des semaines et de ce fait je dois inscrire les semaines à l'avance afin de garder les bonnes informations.
Merci encore pour ta réponse rapide. C'est très apprécié.
Bonn soirée
Tellement content que j'ai oublié de fermer le message
Merci encore