Comment accélérer l'enregistrement
bonjour a tous je vous explique ce que j'aurais besoin
dans la colonne A le nom des fichiers source (il peut y avoir des noms différents)avec un lien hypertexte
colonne B ref article (toujours diffèrent)
colonne C ref palette (peut y avoir des différence)
colonne D j'indique le nom du client a qui j'attribut cette article
le truc c'est que quand je clic sur modifier le client il ouvre le fichier modifie une ligne referme le fichier et recommence pour la suivante,
et je dois mettre un "X" en colonne F pour qu'il sache qu'el ligne modifier dans le fichier source, j'aimerais plutôt qu'il enregistre quand il y a un nom dans la colonne D
Sub Modifier_client()
Dim w As Worksheet, c As Range, i&, client$, lig&, fichier$, cc As Range, n&
Set w = Sheets("Feuil1")
If Application.CountIf(w.[F:F], "X") = 0 Then Exit Sub
Application.ScreenUpdating = False
Application.DisplayAlerts = False
For Each c In w.[F:F].SpecialCells(xlCellTypeConstants)
If UCase(c) = "X" Then
i = c.Row
client = w.Cells(i, 4)
lig = Val(w.Cells(i, 5))
If lig <= 0 Then
w.Cells(i, 6) = ""
Else
fichier = w.Cells(i, 1).Hyperlinks(1).Address
If Dir(fichier) = "" Then fichier = ThisWorkbook.Path & "\" & fichier
With Workbooks.Open(fichier).Sheets(1) 'ouvre le fichier
Set cc = .Cells.Find("AFFAIRE/CLIENT")
If cc Is Nothing Then
w.Cells(i, 6) = ""
Else
n = n + 1
.Cells(lig, cc.Column) = client
End If
.Parent.Close Not cc Is Nothing 'enregistre et ferme le fichier
End With
End If
End If
Next
MsgBox n & " cellule(s) modifiée(s) dans les fichiers sources"
End Submerci d'avance a tous
oups voici les fichiers joint
Bonjour,
Pourquoi explorer toute la liste lorsque tu cliques sur "Modifier client" ?
Pour modifier à la demande : supprimer la boucle qui examine toutes les lignes, se positionner sur la ligne à modifier et utiliser le bouton "Modifier" si besoin.
Ainsi tu ne met à jour que le fichier de la ligne pointée. Pas besoin d'utiliser "X" et donc le test dans la macro.
A voir selon tes besoins
Eric
je sais pas je ne connais rien en vba ,je tâtonne je prend des bouts de code a droite a gauche et je test .
je voudrais que quand il y a 10 lignes a modifier il ne referme pas le fichier a chaque ligne.
merci pour ta réponse
Re,
Voici la macro modifiée pour une maj à la demande (se placer sur la ligne à modifier)
Sub Modifier_client()
Dim i As Long, client As String, lig As Long, fichier As String, cc As Range, n As Long
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Sheets("Feuil1").Activate
i = ActiveCell.Row ' N° de la ligne pointée
client = Cells(i, 4) ' Extrait client
If client <> "" Then
' Client présent
lig = Val(Cells(i, 5))
If lig <= 0 Then
' Ligne invalide
Cells(i, 6) = ""
MsgBox "N° de ligne invalide en colonne E", vbCritical, "Mise à jour"
Else
' Ligne ok
fichier = Cells(i, 1).Hyperlinks(1).Address
If Dir(fichier) = "" Then fichier = ThisWorkbook.Path & "\" & fichier
With Workbooks.Open(fichier).Sheets(1) 'ouvre le fichier
Set cc = .Cells.Find("AFFAIRE/CLIENT")
If cc Is Nothing Then
.Cells(i, 6) = ""
MsgBox "Impossible de mettre à jour", vbCritical, "Mise à jour"
Else
n = n + 1
.Cells(lig, cc.Column) = client
MsgBox n & " cellule(s) modifiée(s) dans le fichier source"
End If
.Parent.Close Not cc Is Nothing 'enregistre et ferme le fichier
End With
End If
Else
' Client vide
MsgBox "Absence de référence client", vbCritical, "Mise à jour"
End If
Application.ScreenUpdating = True
Application.DisplayAlerts = True
End SubA tester et à modifier si besoin.
Pour le reste à toi de voir.
Bonne journée
merci Eric_angers pour ta réponse ,
le code fonctionne bien , mais pour une ligne si j'ai 50 lignes a faire il faut ce positionner sur chaque ligne et cliquer sur enregistrer a chaque fois
je modifie actuellement environ 2500 lignes dans different fichiers par jours c'est pour gagner du temps que je cherche a faire un code qui me simplifie la vie
merci a toi
Bonjour,
Questions :
1 - La mise à jour doit être faite dès lors qu'un nom est présent en colonne D (Affaire client) ?
2 - Après la mise à jour, le nom peut être effacé de la ligne ?
Si oui à ces questions on peut faire un balayage de la liste et tout mettre à jour, si un nom est présent : on met à jour et on efface le nom ...
je vais essayé d'être plus clair
dans les fichiers source environ 30 fichiers il y 2 colonnes "S/N et Pallet no." dans le quelle il y a des référence produit et en colonne "affaire/client" j'indique le nom et du client a qui j'attribut cette article
sur limage si dessous quand je rentre en G1 une ref il importe toutes les lignes qui on cette ref et on constate en colonne affaire/client qu'il importe aussi les lignes qui sont déjà attribué au client(cellule D17 à D28)
je voudrais qu'il n'importe pas les lignes déjà attribué seulement les lignes ou la cellule et vide en colonne Affaire/client
de cette manière je pourrais plus facilement effectuer l'enregistrement des attributions de ligne sans avoir a mettre de X
merci a toi
Bonsoir,
Ton affaire a l'air un peu compliquée. Je pense qu'il vaut mieux que tu restes sur ta 1ère idée (avec le X) en l'améliorant au besoin.
En cherchant un peu dans les forums (ici ou ailleurs), tu trouveras des idées. Un minimum d'apprentissage s'impose, c'est ainsi que petit à petit, en tâtonnant on arrive à ses fins.
Dsl de ne pouvoir faire plus.
Bon courage
Bonjour largo, le fil, le forum,
Un essai :
Il y a un traitement qui reste à faire selon de nouvelles explications.
La colonne "A" contient le nom du fichier à traiter.
Dans ton fichier exemple, le fichier à traiter est toujours le même.
Si dans le fichier de travail, en colonne "A", si le fichier à traiter revient en plusieurs exemplaires, il est possible de minimiser le nombre d'ouvertures et de fermetures si le tri de la colonne "A" ne posait pas problème.
En attendant, le traitement avec "Ouverture et Fermeture" du fichier cible se fera à chaque ligne, ce qui peut-être long pour 400 lignes.
Sub Modifier_client()
Dim ws As Worksheet
Dim cell As Range
Dim rowNum As Long
Dim clientName As String
Dim targetRow As Long
Dim filePath As String
Dim clientCell As Range
Dim modifiedCount As Long
Dim lastRow As Long
' Set worksheet
Set ws = Sheets("Feuil1")
' Find the last row in column A
lastRow = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row
' Disable screen updating and alerts for performance
Application.ScreenUpdating = False
Application.DisplayAlerts = False
On Error GoTo ErrorHandler ' Start error handling
' Loop through the range D4 to the last row in column D
For Each cell In ws.Range("D4:D" & lastRow).SpecialCells(xlCellTypeConstants)
If Len(cell.Value) > 0 Then ' Check if the cell is not empty
rowNum = cell.Row
clientName = ws.Cells(rowNum, 4).Value
targetRow = Val(ws.Cells(rowNum, 5).Value)
If targetRow <= 0 Then
''' ws.Cells(rowNum, 6).Value = ""
Else
filePath = ws.Cells(rowNum, 1).Hyperlinks(1).Address
filePath = Replace(filePath, "/", "\")
' Check if the file exists, if not, prepend the workbook path
If Dir(filePath) = "" Then
filePath = ThisWorkbook.Path & "\" & filePath
End If
' Open the workbook and update the client name
With Workbooks.Open(filePath).Sheets(1)
Set clientCell = .Cells.Find("AFFAIRE/CLIENT")
If clientCell Is Nothing Then
Else
modifiedCount = modifiedCount + 1
.Cells(targetRow, clientCell.Column).Value = clientName
End If
.Parent.Close SaveChanges:=Not clientCell Is Nothing ' Save and close the file
End With
End If
End If
Next cell
' Notify the user of the number of modifications made
MsgBox modifiedCount & " cellule(s) modifiée(s) dans les fichiers sources"
Cleanup:
' Restore screen updating and alerts
Application.ScreenUpdating = True
Application.DisplayAlerts = True
Exit Sub
ErrorHandler:
MsgBox "An error occurred: " & Err.Description
Resume Cleanup
End SubBizz
bonjour a tous désolé de ne pas avoir répondu plutôt (vacance)
merci a toi Bizarre ton code m'a bien aidé
voila ou j'en suis j'ai modifier le code , j'ai mis 3 BOUTON
1 qui effectue la recherche dans plusieurs fichiers d'un dossier " ca c'est OK"
1 qui suite a la recherche efface toutes les lignes ou un article et déjà attribué a un client en colonne "D3" " ca c'est OK"
1 qui enregistre les modifications dans le fichier source de la colonne D et mets en jaune les cellules de la colonne S/N et Pallet No. " ca c'est ok)
mais j'ai toujours le problème que pour enregistrer les modifications il ouvre et referme le fichiers pour chaque ligne (ATTENTION il et possible que en colonne "A" il y est des nom de fichiers diffèrent.
Sub Modifier_client()
Dim ws As Worksheet
Dim cell As Range
Dim rowNum As Long
Dim clientName As String
Dim targetRow As Long
Dim filePath As String
Dim clientCell As Range
Dim snCell As Range
Dim palletNoCell As Range
Dim modifiedCount As Long
Dim lastRow As Long
Dim wb As Workbook
Dim wsToUpdate As Worksheet
Dim sh As Worksheet
' Définir la feuille de calcul
Set ws = Sheets("Feuil1")
' Trouver la dernière ligne dans la colonne A
lastRow = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row
' Désactiver la mise à jour de l'écran et les alertes pour les performances
Application.ScreenUpdating = False
Application.DisplayAlerts = False
On Error GoTo GestionErreur ' Commencer la gestion des erreurs
' Boucler à travers la plage D4 jusqu'à la dernière ligne de la colonne D
For Each cell In ws.Range("D4:D" & lastRow).SpecialCells(xlCellTypeConstants)
If Len(cell.Value) > 0 Then ' Vérifier si la cellule n'est pas vide
rowNum = cell.Row
clientName = ws.Cells(rowNum, 4).Value
targetRow = Val(ws.Cells(rowNum, 5).Value)
If targetRow <= 0 Then
ws.Cells(rowNum, 6).Value = ""
Else
filePath = ws.Cells(rowNum, 1).Hyperlinks(1).Address
filePath = Replace(filePath, "/", "\")
' Vérifier si le fichier existe, sinon, ajouter le chemin du classeur
If Dir(filePath) = "" Then
filePath = ThisWorkbook.Path & "\" & filePath
End If
' Ouvrir le classeur et mettre à jour les informations nécessaires
Set wb = Workbooks.Open(filePath)
For Each sh In wb.Sheets
With sh
Set clientCell = .Cells.Find("AFFAIRE/CLIENT")
Set snCell = .Cells.Find("S/N")
Set palletNoCell = .Cells.Find("Pallet No.")
If Not clientCell Is Nothing Then
modifiedCount = modifiedCount + 1
.Cells(targetRow, clientCell.Column).Value = clientName
End If
If Not snCell Is Nothing Then
modifiedCount = modifiedCount + 1
.Cells(targetRow, snCell.Column).Value = ws.Cells(rowNum, "B").Value
' Mettre en surbrillance la cellule en jaune
.Cells(targetRow, snCell.Column).Interior.Color = RGB(255, 255, 0)
End If
If Not palletNoCell Is Nothing Then
modifiedCount = modifiedCount + 1
.Cells(targetRow, palletNoCell.Column).Value = ws.Cells(rowNum, "C").Value
' Mettre en surbrillance la cellule en jaune
.Cells(targetRow, palletNoCell.Column).Interior.Color = RGB(255, 255, 0)
End If
End With
Next sh
wb.Close SaveChanges:=True ' Enregistrer et fermer le fichier
End If
End If
Next cell
' Informer l'utilisateur du nombre de modifications effectuées
MsgBox modifiedCount & " cellule(s) modifiée(s) dans les fichiers sources"
Nettoyage:
' Restaurer la mise à jour de l'écran et les alertes
Application.ScreenUpdating = True
Application.DisplayAlerts = True
Exit Sub
GestionErreur:
MsgBox "Une erreur s'est produite : " & Err.Description
Resume Nettoyage
End Submerci a tous pour votre aide
Bonjour largo, le fil, le forum,
Un essai :
- vérifie le fichier "recherche-en-cour" en colonne D, si la cellule n'est pas vide.
- lire le numéro de la ligne à traiter en colonne E.
- ouvrir fichier de l'hyperlien (colonne A) s'il n'est pas déjà ouvert.
- si la cellule colonne D du fichier de l'hyperlien n'est pas vide > passer droit > sinon écrire les infos.
- ne fermer le fichier de l'hyperlien que s'il est différent du fichier à traiter suivant ou si le traitement est terminé.
Sub Modifier_client()
Dim ws As Worksheet
Dim cell As Range
Dim rowNum As Long
Dim clientName As String
Dim targetRow As Long
Dim filePath As String
Dim clientCell As Range
Dim snCell As Range
Dim paletteNoCell As Range
Dim modifiedCount As Long
Dim lastRow As Long
Dim wb As Workbook
Dim sh As Worksheet
Dim FichierDeRecherche As Workbook
Dim LignePrecedente As Integer
Dim Ouvert As Boolean
Dim Classeur_OLD As Workbook
Set FichierDeRecherche = ActiveWorkbook
' Définir la feuille de calcul
Set ws = FichierDeRecherche.Sheets("Feuil1")
' Trouver la dernière ligne dans la colonne A
lastRow = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row
' Désactiver la mise à jour de l'écran et les alertes pour les performances
Application.ScreenUpdating = False
Application.DisplayAlerts = False
On Error GoTo GestionErreur ' Commencer la gestion des erreurs
' Boucler à travers la plage D4 jusqu'à la dernière ligne de la colonne D
For Each cell In ws.Range("D4:D" & lastRow).SpecialCells(xlCellTypeConstants)
If Len(cell.Value) > 0 Then ' Vérifier si la cellule n'est pas vide
rowNum = cell.Row
clientName = ws.Cells(rowNum, 4).Value
targetRow = Val(ws.Cells(rowNum, 5).Value)
If targetRow <= 0 Then
ws.Cells(rowNum, 6).Value = ""
Else
filePath = ws.Cells(rowNum, 1).Hyperlinks(1).Address
filePath = Replace(filePath, "/", "\")
' Vérifier si le fichier existe, sinon, ajouter le chemin du classeur
If Dir(filePath) = "" Then
filePath = ThisWorkbook.Path & "\" & filePath
End If
' Si pas déjà ouvert, ouvrir le classeur et mettre à jour les informations nécessaires
Ouvert = False
For Each Classeur_OLD In Workbooks
If Classeur_OLD.FullName = filePath Then
Ouvert = True
Set wb = Classeur_OLD
Exit For
End If
Next Classeur_OLD
If Not Ouvert Then
If LignePrecedente > 0 Then
If ws.Cells(rowNum, 1).Hyperlinks(1).Address <> ws.Cells(LignePrecedente, 1).Hyperlinks(1).Address Then
wb.Close SaveChanges:=True ' Enregistrer et fermer le fichier
End If
End If
Set wb = Workbooks.Open(filePath)
End If
' lire dans le fichier
For Each sh In wb.Sheets
With sh
Set clientCell = .Cells.Find("AFFAIRE/CLIENT")
Set snCell = .Cells.Find("S/N")
Set paletteNoCell = .Cells.Find("Pallet No.")
If Not clientCell Is Nothing And IsEmpty(.Cells(targetRow, clientCell.Column)) Then
modifiedCount = modifiedCount + 1
.Cells(targetRow, clientCell.Column).Value = clientName
End If
If Not snCell Is Nothing Then
modifiedCount = modifiedCount + 1
.Cells(targetRow, snCell.Column).Value = ws.Cells(rowNum, "B").Value
' Mettre en surbrillance la cellule en jaune
.Cells(targetRow, snCell.Column).Interior.Color = RGB(255, 255, 0)
End If
If Not paletteNoCell Is Nothing Then
modifiedCount = modifiedCount + 1
.Cells(targetRow, paletteNoCell.Column).Value = ws.Cells(rowNum, "C").Value
' Mettre en surbrillance la cellule en jaune
.Cells(targetRow, paletteNoCell.Column).Interior.Color = RGB(255, 255, 0)
End If
End With
Next sh
If LignePrecedente > 0 Then
If ws.Cells(rowNum, 1).Hyperlinks(1).Address <> ws.Cells(LignePrecedente, 1).Hyperlinks(1).Address Then
wb.Close SaveChanges:=True ' Enregistrer et fermer le fichier
End If
End If
End If
End If
LignePrecedente = cell.Row
Next cell
' Informer l'utilisateur du nombre de modifications effectuées
MsgBox modifiedCount & " cellule(s) modifiée(s) dans les fichiers sources"
Nettoyage:
' Restaurer la mise à jour de l'écran et les alertes
Application.ScreenUpdating = True
Application.DisplayAlerts = True
On Error Resume Next
wb.Close SaveChanges:=True ' Enregistrer et fermer le fichier
On Error GoTo 0
FichierDeRecherche.Activate
Exit Sub
GestionErreur:
MsgBox "Une erreur s'est produite : " & Err.Description
Resume Nettoyage
End SubIl restera peut-être à indiquer d'une façon quelconque dans le fichier "recherche-en-cour" que telle ligne a été passée ou écrite dans le fichier de l'hyperlien.
Bizz
salut Bizarre ca fonctionne nickel
je vais faire des tests au boulot je te tiens au courant
merci infiniment