Copier des données d'un ancien tableau sur un nouveau
Bonjour,
J'ai passé des dizaines d'heures pour essayer de copier des données d'un ancien tableau sur un nouveau sans succès.
C'est parce que souvent, une résolution d'un sujet ou une correction sont apportées sur un mauvais fichier, une ancienne version, alors qu'entre temps j'avais fait un grand nombre de modification. C'est la 2ème fois en 1 semaine que je suis obligé de procéder ainsi.
Pourtant je désactive les macros mais visiblement ça n'est pas suffisant :-(((((((((((((((
Quand je copie ça provoque des buggs de partout pourtant il ne s'agit que des cellules sans formule et des colonnes strictement identiques d'un tableau sur l'autre.
Je suis désespéré car j'ai fait un nombre hallucinant de tests mais sans succès...
Il faudrait faire ou désactiver autre chose ?
J'ai 2 erreurs successives et ensuite je tourne en rond et je suis obligé de faire un arrêt forcé de tous les fichiers Excel en cours d'exécution :-))))) Il s'agit surement d'une boucle sans fin provoquée par le code VBA...
Merci pour la lecture de mon sujet :-)))))
Le nouveau fichier :
L'ancien fichier dont j'essaye de copier certaines données sur le nouveau :
Bonne journée :-))))))))))))))))))
Bonjour
Comme d'habitude... pourquoi ne pas faire appel à BsAlv
Bonjour Jexcel2fr,
Je l'ai assez embêté... D'ailleurs s'il portait plainte pour harcèlement, des millions pourraient lui être donnésen dédommagement ;-))))))))))
En plus, je vois bien qu'il aide énormément de personnes sur des sujets très variés... sa patience a des limites ;-))))))))
Bon w.e. :-)))))
Bonjour,
Essayez ceci:
Ouvrez les 2 fichiers excel dans la même session, puis collez la macro suivante dans un module standard du fichier"6-challenge-national-10-epreuves-sportives-2025-new" et lancez la macro "Exporter"
Avant toutes choses, faites une copie du fichier de destination, au cas où!
Dim DerLig_Sh As Long
Sub Exporter()
Dim Wk_Orig As Object, Wk_Dest As Object, Tabl As Object
Dim Sh As Worksheet
On Error GoTo Sortie
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Application.EnableEvents = False
Set Wk_Orig = Windows("6-challenge-national-10-epreuves-sportives-2025-new.xlsb")
Set Wk_Dest = Windows("6-challenge-national-10-epreuves-sportives-2025-new-1-1.xlsb")
Set Sh = Sheets("Classmt par discipline+Général")
Set Tabl = Sh.Range("Tabel1")
DerLig_Sh = Tabl.ListObject.ListRows.Count
ActiveSheet.Unprotect "seb"
Range("Tabel1[[rank]:[Col_67]]").Copy
Wk_Dest.Activate
ActiveSheet.Unprotect "seb"
Range("A5").Select
ActiveSheet.Paste
Formules
ActiveSheet.Protect "seb", DrawingObjects:=True, Contents:=True, Scenarios:=True _
, AllowDeletingRows:=True, AllowSorting:=True, AllowFiltering:=True
Sortie:
Application.ScreenUpdating = True
Application.DisplayAlerts = True
Application.EnableEvents = True
End Sub
Sub Formules()
Dim i As Long
'Renseignements personnels
Range("H5").FormulaR1C1 = "=IF(RC[-1]="""",28,(TODAY()-RC[-1])/365.25)"
Range("L5").FormulaR1C1 = "=IF(RC[2]="""","""",RANK(RC[2],R5C[2]:R" & DerLig_Sh & "C[2],0))"
Range("M5").FormulaR1C1 = "=IF(RC[-2]="""","""",VLOOKUP(RANK(RC[-2],[E_1],0),Tabel1,2,1))"
Range("N5").FormulaR1C1 = "=IF(ISNUMBER(RC[-1]),RC[-1]+RC[-1]*(MAX(0,RC8-28))*1.5/100,"""")"
'Tractions
Range("Q5").FormulaR1C1 = "=IFERROR(IF(AND(RC[-7]=0,RC[-8]=0),"""",437.8*RC[-1]*RC[-8]/(RC[-7]*RC[-7])),"""")"
Range("R5").FormulaR1C1 = "=IF(RC[2]="""","""",RANK(RC[2],R5C[2]:R" & DerLig_Sh & "C[2],0))"
Range("S5").FormulaR1C1 = "=IF(RC[-2]="""","""",VLOOKUP(RANK(RC[-2],[Col_17],0),Tabel1,2,1))"
Range("T5").FormulaR1C1 = "=IF(ISNUMBER(RC[-1]),RC[-1]+RC[-1]*(MAX(0,RC8-28))*1.5/100,"""")"
'LUC-LEGER Chronométré
Range("BF5").FormulaR1C1 = "=IF(RC[2]="""","""",RANK(RC[2],R5C[2]:R" & DerLig_Sh & "C[2],0))"
Range("BG5").FormulaR1C1 = "=IF(RC[-2]="""","""",VLOOKUP(RANK(RC[-2],[E_10],0),Tabel1,2,1))"
Range("BH5").FormulaR1C1 = "=IF(ISNUMBER(RC[-1]),RC[-1]+RC[-1]*(MAX(0,RC8-28))*1.5/100,"""")"
Range("BI5").FormulaR1C1 = "=IF([@[E_10]]="""","""",[@[E_10]]*1440)"
Range("BJ5").FormulaR1C1 = "=IF([@palier]="""","""",8+0.5*([@palier]-1))"
'Toutes les autres épreuves
For i = 23 To 53 Step 5
Range(Cells(5, i), Cells(DerLig_Sh, i)).FormulaR1C1 = "=IF(RC[2]="""","""",RANK(RC[2],R5C[2]:R" & DerLig_Sh & "C[2],0))"
Range(Cells(5, i + 1), Cells(DerLig_Sh, i + 1)).FormulaR1C1 = "=IF(RC[-2]="""","""",VLOOKUP(RANK(RC[-2],[E_3],0),Tabel1,2,1))"
Range(Cells(5, i + 2), Cells(DerLig_Sh, i + 2)).FormulaR1C1 = "=IF(ISNUMBER(RC[-1]),RC[-1]+RC[-1]*(MAX(0,RC8-28))*1.5/100,"""")"
Next i
End SubCdlt
Bonjour Arturo83 et merci beaucoup :-))))))))))))))))))))
Est-ce vraiment nécessaire, la dernière partie du code car pour les copier/coller, je ne vx faire que des perfs sur des perfs, c-à-d sans formules ?
Et je peux laisser toutes les macros actives ?
Qu'en penses-tu ?
Merci
Bonne journée :-))))))))))))))))))))
L'exportation va me transporter absolument toutes les données ?
L'exportation va me transporter absolument toutes les données ?
Oui, et pour les formules, il vous les faudra bien sinon comment se feront les calculs? si vous ne les voulez pas, il suffit de mettre une apostrophe devant la ligne suivante, ainsi elles ne seront plus exécutées:
FormulesJ'ai exécuté mais rien ne se passe :
Et après j'ai exécuté "Formules" et j'ai une erreur :
Attention, il faut lancer la macro "Exporter" et pas "Formules",
Si vous souhaitez lancer la macro "Formules" à part, il faut la modifier. je vous remets le code intégral:
Dim DerLig_Sh As Long
Dim Sh As Worksheet
Dim Tabl As Object
Sub Exporter()
Dim Wk_Orig As Object, Wk_Dest As Object
On Error GoTo Sortie
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Application.EnableEvents = False
Set Wk_Orig = Windows("6-challenge-national-10-epreuves-sportives-2025-new.xlsb")
Set Wk_Dest = Windows("6-challenge-national-10-epreuves-sportives-2025-new-1-1.xlsb")
Set Sh = Sheets("Classmt par discipline+Général")
Set Tabl = Sh.Range("Tabel1")
DerLig_Sh = Tabl.ListObject.ListRows.Count
ActiveSheet.Unprotect "seb"
Range("Tabel1[[rank]:[Col_67]]").Copy
Wk_Dest.Activate
ActiveSheet.Unprotect "seb"
Range("A5").Select
ActiveSheet.Paste
Formules
ActiveSheet.Protect "seb", DrawingObjects:=True, Contents:=True, Scenarios:=True _
, AllowDeletingRows:=True, AllowSorting:=True, AllowFiltering:=True
Sortie:
Application.ScreenUpdating = True
Application.DisplayAlerts = True
Application.EnableEvents = True
End Sub
Sub Formules()
Dim i As Long
Dim Sh As Worksheet
Set Sh = Sheets("Classmt par discipline+Général")
Set Tabl = Sh.Range("Tabel1")
DerLig_Sh = Tabl.ListObject.ListRows.Count
ActiveSheet.Unprotect "seb"
'Renseignements personnels
Sh.Range("H5:H" & DerLig_Sh).FormulaR1C1 = "=IF(RC[-1]="""",28,(TODAY()-RC[-1])/365.25)"
Sh.Range("L5:L" & DerLig_Sh).FormulaR1C1 = "=IF(RC[2]="""","""",RANK(RC[2],R5C[2]:R" & DerLig_Sh & "C[2],0))"
Sh.Range("M5:M" & DerLig_Sh).FormulaR1C1 = "=IF(RC[-2]="""","""",VLOOKUP(RANK(RC[-2],[E_1],0),Tabel3,2,1))"
Sh.Range("N5:N" & DerLig_Sh).FormulaR1C1 = "=IF(ISNUMBER(RC[-1]),RC[-1]+RC[-1]*(MAX(0,RC8-28))*1.5/100,"""")"
'Tractions
Sh.Range("Q5:Q" & DerLig_Sh).FormulaR1C1 = "=IFERROR(IF(AND(RC[-7]=0,RC[-8]=0),"""",437.8*RC[-1]*RC[-8]/(RC[-7]*RC[-7])),"""")"
Sh.Range("R5:R" & DerLig_Sh).FormulaR1C1 = "=IF(RC[2]="""","""",RANK(RC[2],R5C[2]:R" & DerLig_Sh & "C[2],0))"
Sh.Range("S5:S" & DerLig_Sh).FormulaR1C1 = "=IF(RC[-2]="""","""",VLOOKUP(RANK(RC[-2],[Col_17],0),Tabel3,2,1))"
Sh.Range("T5:T" & DerLig_Sh).FormulaR1C1 = "=IF(ISNUMBER(RC[-1]),RC[-1]+RC[-1]*(MAX(0,RC8-28))*1.5/100,"""")"
'LUC-LEGER Chronométré
Sh.Range("BF5:BF" & DerLig_Sh).FormulaR1C1 = "=IF(RC[2]="""","""",RANK(RC[2],R5C[2]:R" & DerLig_Sh & "C[2],0))"
Sh.Range("BG5:BG" & DerLig_Sh).FormulaR1C1 = "=IF(RC[-2]="""","""",VLOOKUP(RANK(RC[-2],[E_10],0),Tabel3,2,1))"
Sh.Range("BH5:BH" & DerLig_Sh).FormulaR1C1 = "=IF(ISNUMBER(RC[-1]),RC[-1]+RC[-1]*(MAX(0,RC8-28))*1.5/100,"""")"
Sh.Range("BI5:BI" & DerLig_Sh).FormulaR1C1 = "=IF([@[E_10]]="""","""",[@[E_10]]*1440)"
Sh.Range("BJ5:BJ" & DerLig_Sh).FormulaR1C1 = "=IF([@palier]="""","""",8+0.5*([@palier]-1))"
'Toutes les autres épreuves
For i = 23 To 53 Step 5
Range(Sh.Cells(5, i), Sh.Cells(DerLig_Sh, i)).FormulaR1C1 = "=IF(RC[2]="""","""",RANK(RC[2],R5C[2]:R" & DerLig_Sh & "C[2],0))"
Range(Sh.Cells(5, i + 1), Sh.Cells(DerLig_Sh, i + 1)).FormulaR1C1 = "=IF(RC[-2]="""","""",VLOOKUP(RANK(RC[-2],[E_3],0),Tabel3,2,1))"
Range(Sh.Cells(5, i + 2), Sh.Cells(DerLig_Sh, i + 2)).FormulaR1C1 = "=IF(ISNUMBER(RC[-1]),RC[-1]+RC[-1]*(MAX(0,RC8-28))*1.5/100,"""")"
Next i
End SubPs: j'ai laissé l'appel de la macro "Formules" dans la macro "Exporter", mettez une apostrophe devant "Formules " dans la macro "Exporter" si vous ne souhaitez pas recréer les formules lors de l'exportation.
C'est ce que j'ai fait :
- J'avais essayé d'exécuter "Exporter" mais rien...
- Et je m'étais dit après, qu'il fallait peut-être lancer "Formules"
Donc d'accord ça n'est que "Exporter"
Et c'est ce que je viens de faire avec ce nouveau code mais toujours rien, désolé...
Il n'y aurait pas une autre façon de faire puisque je n'ai qu'à copier/coller les perfs de 5 disciplines (donc 5 colonnes) :
- Désactiver peut-être les macros...
- Et quoi d'autres pour que je n'ai pas de pbs ?
Merci en tout cas Arthuro83 :-)))))))
ça ne viendrait pas des noms qui sont différents entre l'enregistrement automatique du forum et mes véritables fichiers :
Set Wk_Orig = Windows("6-challenge-national-10-epreuves-sportives-2025-new.xlsb")
Set Wk_Dest = Windows("6-challenge-national-10-epreuves-sportives-2025-new-1-1.xlsb")
Il vaut mieux que je change lesquels, ? Mes fichiers ou les noms que tu as donné dans la macro ?
Merci
à+
Bonjour,
En effet, les noms des fichiers ne correspondent pas à ce que j'ai écrit.
il faut remplacer
Set Wk_Orig = Windows("6-challenge-national-10-epreuves-sportives-2025-new.xlsb")
par
Set Wk_Orig = Windows("6-challenge-national-10-epreuves-sportives-2025 NEW.xlsb")
2 anomalies trouvées,
- la première "NEW" est écrit en majuscules au lieu de "new" auparavant, pour corriger ce petit problème et sans réécrire le mot "NEW", veuillez ajouter tout en haut du module en première ligne et en dehors des macros, ceci:"Option compare text", ainsi, tout texte saisi en minuscules ou en majuscules n'a aucune incidence sur le bon déroulement du programme.
- la deuxième, il n'y a plus le petit tiret devant "NEW", alors qu'il était présent auparavant "-new" ce qui évidemment change le nom du fichier.
Cdlt
Bonjour Arturo83,
MErci pour les explications précises :-))))))))))))))
On se réveille tôt le matin, tout comme moi :-))))))
Ca marche "exporter" en cliquant 2 fois de suite dessus ;-)))))
J'ai pas mal de #N/A.
Je suis en train d'essayer de les comprendre. Par exemple ces 2 là sont incompréhensibles puisque j'ai comparé la formule, c'est tout pareil. J'ai changé la perf pour voir mais ça ne fonctionne pas non plus.
J'ai comparé les feuilles "concordances" des 2 fichiers : elles sont identiques
Autre chose, à compter de la 29ème place, je n'ai plus la suite : 30,31,32,33, etc...
Mais ça ça vient du nouveau code de BsAlv qui m'avait changé le code pour avoir un classement complet ;-))))))
Est-ce qu'on ne pourrait exporter que les colonnes où y'a les perfs (ce sont des cellules sans formule en plus) ?
Qu'en penses-tu ?
Fichier avant l'exportation :
Fichier après :
Merci
à +
bonjour Vodoraix, salut Artur083
un autre essai, à mettre dans un nouveau module, éventuellement il faut changer les 2 premières lignes
Private Const sNom_ancien = "6-challenge-national-10-epreuves-sportives-2025-new (2).xlsb" 'nom de l'ancien fichier
Private Const sDossier = "" 'nom du dossier de l'ancien fichier, vide s'il se trouve dans lem même dossier que le fichier actuel
Sub Copier_Anciennes_Données()
Dim WB As Workbook, aHeaders, aDBR, LO
'**********************************************************************
'thisworkbook = le fichier actuel = contient les bonnes formules
'sNom_ancien = le fichier qui contient les bonnes données
'sDossier = le nom du dossier si l'ancien fichier ne se trouve pas dans le même dossier
'**********************************************************************
On Error Resume Next
Set WB = Workbooks(sNom_ancien) 'ancien fichier déjà ouvert ?
bOpen = (Not WB Is Nothing)
If Not bOpen Then
s = IIf(sDossier = "", ThisWorkbook.Path, sDossier)
s = s & IIf(Right(s, 1) = "\", "", "\") & sNom_ancien 'composer le dossier & nom
'MsgBox s
Set WB = Workbooks.Open(s) 'ouvrir le fichper
End If
On Error Resume Next
If WB Is Nothing Then 'impossible d'accèder le fichier
MsgBox "Fichier introuvable" & vbLf & vbLf & sDossier & vbLf & sNom_ancien, vbCritical, s
Else
Set LO = WB.Sheets("Classmt par discipline+Général").Range("tabel1").ListObject 'le TS
With LO
aHeaders = .HeaderRowRange.Value2 'lire les entêtes
aDBR = .DataBodyRange.Value2 'lire le body
End With
ThisWorkbook.Activate 'activer notre workbook
If Not bOpen Then WB.Close 0 'eventullement fermer l'autre workbook
Enlever_Protection_Et_Events 'enlever protection et bloquer évenements
With Range("tabel1").ListObject 'ce TS
b = True 'drapeau
.ListColumns(1).DataBodyRange.Resize(UBound(aDBR)).Value = "X"
For j = 1 To .ListColumns.Count 'boucler les colonnes
If StrComp(.HeaderRowRange.Cells(1, j).Value2, aHeaders(1, j), 1) <> 0 Then 'se rassurer que c'est la même colonne
MsgBox "problèmes avec entête de la colonne J", vbCritical, aHeaders(1, j)
b = False
Exit For 'arrêter dès qu'on a une erreur
Else
With .ListColumns(j).DataBodyRange 'le databody de cette colonne
If Not .Cells(1).HasFormula Then .Resize(UBound(aDBR), 1).Value = Application.Index(aDBR, , j) 'si la colonne n'a pas des formules,coller contenu
End With
End If
Next
If b And UBound(aDBR) < .ListRows.Count Then .DataBodyRange.Offset(UBound(aDBR)).Resize(.ListRows.Count - UBound(aDBR)).Delete 'eventuellement supprimer des lignes supplémentaires
.ListColumns(1).DataBodyRange.FormulaR1C1 = "=IF(RC[64]="""","""",RANK(RC[64],R5C[64]:R67C[64]))" 'renouveller formule de la première colonne
End With
M_Proteger True
End If
End SubBonjour BsAlv et merci beaucoup :-))))))))))))))))
En vécu, même si j'ai confiance à 100% en tes solutions, je laisse Arturo83 te répondre. Tu as dû capter depuis longtemps que je ne comprends pas grand chose ;-)))))
Juste ça change toutes les données de l'ancien fichier ou c'est juste les Perfs qui sont rapportées ?
Mais je crois que j'ai ma réponse avec ce code, nan ? ;-)))))))))))))))
Application.Index(aDBR, , j) 'si la colonne n'a pas des formules,coller contenu
End With
End If
NextEt merci à vous 2 pour tout le temps que ça vous prend !!!!!!!!!!!!!!!!!!!!!!!!!!!!!
à + :-))))))))))))))))))))
bien lire est aussi un donJe suis en train d'essayer de les comprendre. Par exemple ces 2 là sont incompréhensibles puisque j'ai comparé la formule, c'est tout pareil. J'ai changé la perf pour voir mais ça ne fonctionne pas non plus.
si vous regardez la formule en AB16:
=SI(AD16="";"";RANG(AD16;AD$5:AD$63;0))
vous pouvez voir quelle ne prend pas tout le tableau qui va jusqu'à la ligne 67. 63 est la dernière ligne du tableau structuré, hors la formule ne tient pas compte du tableau structuré mais plutôt de la plage de cellule qui s'arrête à 67, donc remplacé 63 par 67.
d'autre part, la formule de la colonne AD du nouveau fichier est différente de celle de la même colonne de l'ancien fichier, là aussi c'est peut-être une source d'erreur.
Abracadabra !!!!!! :-))))))))))))))) ça marche et tout semble parfait Bart' ;-)))))
Merci beaucoup à vous 2 :-)))))))))))))))))))
Je ne suis pas obligé de supprimer le module dans lequel j'ai mis ton code Bart' ?
c-à-d qu'il ne s'exécute pas si je ne le provoque pas manuellement ?
J'ai juste un détail que j'avais déjà depuis un moment. C'est que pour toutes les données en dessous de celles entourées (dans rameur 500m et rameur 2000m), je n'ai plus l'info en jaune pour le format, etc.
Et qd j'essaye d'étendre "la validation des données" à toute la colonne, ça ne marche pas. Une idée ?
Encore merci bcp à vous 2 :-)))))))))))))))))))
Bonne aprèm :-)))))))))))))))
je ne comprends pas pourquoi ces validations sont disparues