yangerber64500
XLDnaute Nouveau
Bonjour à tous,
Je possède une macro de retraitement d'un fichier qui fonctionne très bien cependant cette dernière me demande lors d'une étape de rentrer un code article. Ce code article je le possède dans un autre fichier et j'aimerais pouvoir aller le copier (sans macro juste en faisant ctrl+c/ctrl+v). Malheureusement quand ma macro est en cours elle m'empêche d'accéder aux autres classeurs ouverts sur mon ordinateur.
Pensez vous qu'il existe une solution ou bien c'est mon ordinateur qui bloque et je ne peux rien faire ?
voici le code :
Sub traitement_nomenclatures()
'-----------------------------------------------------------------------------------------
'INFO: Cette macro permet de traiter intégralement un fichier de type ...
'Auteur :
'Création:29/01/2013
'Version : 1.1
'Dernière modification :30/01/2013
'------------------------------------------------------------------------------------------
'Figer l'écran pour gagner du temps
Application.ScreenUpdating = False
'I)Trouver la première et la dernière ligne.
Derl = Range("A65536").End(xlUp).Row
plign = Range("A2").Row
'II)Mise forme du fichier
'1)Remplacer les points par des virgules dans la colonne D puis mettre au format nombre
'Recalculer la dernière lign suite aux supressions
Derl = Range("A65536").End(xlUp).Row
'Selectionne la colonne D en fonction de la taille du tableau
Range("D" & plign & "" & Derl).Select
'ATTENTION : Il faut remplacer le point par un point
' car en VBA le point est égal à la virgule.
Selection.Replace What:=".", Replacement:="."
Selection.NumberFormat = "0.00"
'2)Remplacer les points par rien dans la colonne A
Range("A" & plign & ":A" & Derl).Replace What:=".", Replacement:=""
'Cette Boucle permet de supprimer les lignes inutiles.
For a = Derl To plign Step -1
lign = Cells(a, 1).Value
Select Case lign
Case 4
'Stocke le numéros de la ligne contenant un 4
vari_4 = a
Case 3
'Stocke le numéros de la ligne contenant un 3
vari_3 = a
'Compare si la ligne contenant un 4 et au dessous d'une ligne comprenant un 3
vari_r = vari_4 - vari_3
'Si la différence est égale à 1 les lignes sont a côté
'donc il suprime la ligne actuelle
If vari_r = 1 Then
Range("A" & vari_3).EntireRow.Delete
End If
Case 3
'Stocke le numéros de la ligne contenant un 3
vari_3 = a
Case 2
'Stocke le numéros de la ligne contenant un 2
vari_2 = a
'Compare si la ligne contenant un 2 et au dessous d'une ligne comprenant un 3
vari_r = vari_3 - vari_2
'Si la différence est égale à 1 les lignes sont a côté
'donc il suprime la ligne actuelle
If vari_r = 1 Then
Range("A" & vari_2).EntireRow.Delete
End If
Case 1
'Stocke le numéros de la ligne contenant un 1
vari_1 = a
'Compare si la ligne contenant un 1 et au dessous d'une ligne comprenant un 2
vari_r = vari_2 - vari_1
'Si la différence est égale à 1 les lignes sont a côté
'donc il suprime la ligne actuelle
If vari_r = 1 Then
Range("A" & vari_1).EntireRow.Delete
End If
End Select
Next a
'IV)Suprimmer les colonnes qui ne serve à rien de E à R.
Columns("E:R").Delete Shift:=xlToLeft
With ActiveSheet
.Rows(1).ClearContents
.Range("A1") = "1"
.Range("B1") = InputBox("Entrer le code article")
.Range("A2:A" & Range("B65536").End(xlUp).Row) = "0"
.Range("A" & Range("B65536").End(xlUp).Row + 1) = "1"
.Range("E1").FormulaR1C1 = "=SUMPRODUCT(INDEX(R[1]C[-4]:R[149]C,1,4):INDEX(R[1]C[-4]:R[149]C,MATCH(1,R[1]C[-4]:R[149]C[-4],0)-1,4),INDEX(R[1]C[-4]:R[149]C,1,5):INDEX(R[1]C[-4]:R[149]C,MATCH(1,R[1]C[-4]:R[149]C[-4],0)-1,5))"
End With
End Sub
Merci pour votre aide,
Cordialement,
Yan.
Je possède une macro de retraitement d'un fichier qui fonctionne très bien cependant cette dernière me demande lors d'une étape de rentrer un code article. Ce code article je le possède dans un autre fichier et j'aimerais pouvoir aller le copier (sans macro juste en faisant ctrl+c/ctrl+v). Malheureusement quand ma macro est en cours elle m'empêche d'accéder aux autres classeurs ouverts sur mon ordinateur.
Pensez vous qu'il existe une solution ou bien c'est mon ordinateur qui bloque et je ne peux rien faire ?
voici le code :
Sub traitement_nomenclatures()
'-----------------------------------------------------------------------------------------
'INFO: Cette macro permet de traiter intégralement un fichier de type ...
'Auteur :
'Création:29/01/2013
'Version : 1.1
'Dernière modification :30/01/2013
'------------------------------------------------------------------------------------------
'Figer l'écran pour gagner du temps
Application.ScreenUpdating = False
'I)Trouver la première et la dernière ligne.
Derl = Range("A65536").End(xlUp).Row
plign = Range("A2").Row
'II)Mise forme du fichier
'1)Remplacer les points par des virgules dans la colonne D puis mettre au format nombre
'Recalculer la dernière lign suite aux supressions
Derl = Range("A65536").End(xlUp).Row
'Selectionne la colonne D en fonction de la taille du tableau
Range("D" & plign & "" & Derl).Select
'ATTENTION : Il faut remplacer le point par un point
' car en VBA le point est égal à la virgule.
Selection.Replace What:=".", Replacement:="."
Selection.NumberFormat = "0.00"
'2)Remplacer les points par rien dans la colonne A
Range("A" & plign & ":A" & Derl).Replace What:=".", Replacement:=""
'Cette Boucle permet de supprimer les lignes inutiles.
For a = Derl To plign Step -1
lign = Cells(a, 1).Value
Select Case lign
Case 4
'Stocke le numéros de la ligne contenant un 4
vari_4 = a
Case 3
'Stocke le numéros de la ligne contenant un 3
vari_3 = a
'Compare si la ligne contenant un 4 et au dessous d'une ligne comprenant un 3
vari_r = vari_4 - vari_3
'Si la différence est égale à 1 les lignes sont a côté
'donc il suprime la ligne actuelle
If vari_r = 1 Then
Range("A" & vari_3).EntireRow.Delete
End If
Case 3
'Stocke le numéros de la ligne contenant un 3
vari_3 = a
Case 2
'Stocke le numéros de la ligne contenant un 2
vari_2 = a
'Compare si la ligne contenant un 2 et au dessous d'une ligne comprenant un 3
vari_r = vari_3 - vari_2
'Si la différence est égale à 1 les lignes sont a côté
'donc il suprime la ligne actuelle
If vari_r = 1 Then
Range("A" & vari_2).EntireRow.Delete
End If
Case 1
'Stocke le numéros de la ligne contenant un 1
vari_1 = a
'Compare si la ligne contenant un 1 et au dessous d'une ligne comprenant un 2
vari_r = vari_2 - vari_1
'Si la différence est égale à 1 les lignes sont a côté
'donc il suprime la ligne actuelle
If vari_r = 1 Then
Range("A" & vari_1).EntireRow.Delete
End If
End Select
Next a
'IV)Suprimmer les colonnes qui ne serve à rien de E à R.
Columns("E:R").Delete Shift:=xlToLeft
With ActiveSheet
.Rows(1).ClearContents
.Range("A1") = "1"
.Range("B1") = InputBox("Entrer le code article")
.Range("A2:A" & Range("B65536").End(xlUp).Row) = "0"
.Range("A" & Range("B65536").End(xlUp).Row + 1) = "1"
.Range("E1").FormulaR1C1 = "=SUMPRODUCT(INDEX(R[1]C[-4]:R[149]C,1,4):INDEX(R[1]C[-4]:R[149]C,MATCH(1,R[1]C[-4]:R[149]C[-4],0)-1,4),INDEX(R[1]C[-4]:R[149]C,1,5):INDEX(R[1]C[-4]:R[149]C,MATCH(1,R[1]C[-4]:R[149]C[-4],0)-1,5))"
End With
End Sub
Merci pour votre aide,
Cordialement,
Yan.