Copie valeur dans fichier à l'autre - première cellule vide

Bonjour,

J’ai un problème avec une macro car j’ai réussi à faire quelques choses mais je constate que ce n’est pas optimale.

J’ai créé une macro « Att_ralentisseur » dans un fichier Excel afin d’ouvrir un autre fichier Excel « ATTESTATION Ralentisseur 2020 _ News.xlsm » pour copier des valeurs dans du fichier source vers l’autre fichier « ATTESTATION Ralentisseur 2020 _ News.xlsm ».

Ma macro identifie la prochaine cellule vide de la colonne pour copie les valeurs, mais j’ai réussi à faire cela que colonne par colonne. Mon problème est que si un utilisateur réalise une saisie manuelle dans le fichier « ATTESTATION Ralentisseur 2020 _ News.xlsm » et qu’il ne complète pas la totalité des cellules alors lorsque la macro va fonctionner à nouveau, il y aura un décalage des valeurs saisies automatiquement.

Il faudrait que ma macro copie toutes les valeurs sur la même ligne avec référence première cellule vide de la première colonne.

J’espère avoir été suffisamment clair dans mes explications. Je reste à votre disposition pour de plus amples renseignements.

Merci par avance pour votre aide.

CDRIC78

Sub Att_ralentisseur()
'
' Att_ralentisseur Macro
'
'
Rows("1:1").Select
Selection.AutoFilter
ActiveSheet.Range("$A$1:$AM$66").AutoFilter Field:=29, Criteria1:="<>"
Workbooks.Open Filename:= _
"\\C:\Users\Desktop\Prépa Expédition COC\ATTESTATION Ralentisseur 2020 _ News.xlsm"

'Copie Commission
Windows("New 2020.xlsm").Activate
Range("C2:C500").Select
Selection.Copy
Windows("ATTESTATION Ralentisseur 2020 _ News.xlsm").Activate

Dim i As Integer
i = 1
While (Cells(i, 1).Value <> "")
i = i + 1
Wend
Cells(i, 1).Select

Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Windows("New 2020.xlsm").Activate
Rows("1:1").Select
Application.CutCopyMode = False

'Copie N° chassis
Windows("New 2020.xlsm").Activate
Range("a2:a500").Select
Selection.Copy
Windows("ATTESTATION Ralentisseur 2020 _ News.xlsm").Activate

i = 2
While (Cells(i, 2).Value <> "")
i = i + 1
Wend
Cells(i, 2).Select

Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Windows("New 2020.xlsm").Activate
Rows("1:1").Select
Application.CutCopyMode = False


'Copie Dénomination commerciale
Windows("New 2020.xlsm").Activate
Range("h2:h500").Select
Selection.Copy
Windows("ATTESTATION Ralentisseur 2020 _ News.xlsm").Activate

i = 4
While (Cells(i, 4).Value <> "")
i = i + 1
Wend
Cells(i, 4).Select

Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Windows("New 2020.xlsm").Activate
Rows("1:1").Select
Application.CutCopyMode = False


'Copie Code ralentisseur
Windows("New 2020.xlsm").Activate
Range("AC2:AC500").Select
Selection.Copy
Windows("ATTESTATION Ralentisseur 2020 _ News.xlsm").Activate

i = 9
While (Cells(i, 9).Value <> "")
i = i + 1
Wend
Cells(i, 9).Select

Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Windows("New 2020.xlsm").Activate
Rows("1:1").Select
Application.CutCopyMode = False


'Copie Chrono
Windows("New 2020.xlsm").Activate
Range("B2:B500").Select
Selection.Copy
Windows("ATTESTATION Ralentisseur 2020 _ News.xlsm").Activate

i = 8
While (Cells(i, 8).Value <> "")
i = i + 1
Wend
Cells(i, 8).Select

Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Windows("New 2020.xlsm").Activate
Rows("1:1").Select
Application.CutCopyMode = False


Selection.AutoFilter



End Sub

Bonsoir,

Si besoin, je peux apporter des précisions à ma demande.

Bonne soirée à tous!

Bonjour,

Voici un essai :

Sub Att_ralentisseur()

dim wbral as workbook, wbnew as workbook
dim wsral as worksheet, wsnew as worksheet
Dim nvl%

set wbnew = workbooks("New 2020.xlsm") 'thisworkbook
Set wsnew = wbnew.activesheet '<<<<< avec le nom de la feuille, c'est mieux
set wbral = Workbooks.Open("C:\Users\Desktop\Prépa Expédition COC\ATTESTATION Ralentisseur 2020 _ News.xlsm")
set wsral = wbral.sheets(1) '<<<<<<<< ???? ADAPTER

nvl = wsral.cells(wsral.rows.count, 1).end(xlup).row + 1 '1è vide en colonne A de feuille 1 de ralentisseur

with wsnew
    .Rows("1:1").AutoFilter    
    .Range("$A$1:$AM$66").AutoFilter Field:=29, Criteria1:="<>"
    wsral.Cells("A" & nvl).value = .Range("C2:C500").value 'si besoin, remplacer partie gauche par wsral.Cells("A" & nvl).resize(499).value
    wsral.Cells("B" & nvl).value = .Range("a2:a500").value 'idem chaque ligne (avec B) : rajouter resize(499,1)
    wsral.Cells("D" & nvl).value = .Range("h2:h500").value 'idem (D)
    wsral.Cells("I" & nvl).value = Range("AC2:AC500").value 'idem
    wsral.Cells("H" & nvl).value = Range("B2:B500").value 'idem
    .Rows("1:1").AutoFilter
End with

set wbnew = nothing
Set wsnew = nothing
set wbral = nothing
set wsral = nothing

End Sub

Il faudra peut-être adapter si les noms de feuille ne vont pas.

Cdlt,

Bonjour,

Merci 3GB pour ta réponse et ton aide.

J'ai un peu modifié le texte pour adapter à mes fichiers (j'ai juste caché le chemin d'accès avec des noms ).

Je bloque à cette étape, j'a essayé avec les 2 versions (wsral.Cells("A" & nvl).Value = .Range("C2:C500").Value et wsral.Cells("A" & nvl).resize(499).value = .Range("C2:C500").Value) et ça ne veut pas fonctionner. Aurais tu une idée?

Merci par avance.

CEDRIC78

Bonjour Cédric,

Oui, j'ai une petite idée. Je me suis pas intéressé au filtre et il y a des cellules masqués qui probablement posent problème.

Avant tout, peux-tu essayer avec cette ligne (petit oubli de ma part) :

wsral.Cells("A" & nvl).resize(499, 1).value = .Range("C2:C500").value 'et idem pour les autres si ça marche pour celle-là

Ça devrait marcher MAIS, tu risques de prendre également les valeurs masquées... Donc pour les éviter, un essai :

Sub Att_ralentisseur()

dim wbral as workbook, wbnew as workbook
dim wsral as worksheet, wsnew as worksheet
Dim nb%, dl%, i%

set wbnew = workbooks("New 2020.xlsm") 'thisworkbook
Set wsnew = wbnew.activesheet '<<<<< avec le nom de la feuille, c'est mieux
set wbral = Workbooks.Open("C:\Users\Desktop\Prépa Expédition COC\ATTESTATION Ralentisseur 2020 _ News.xlsm")
set wsral = wbral.sheets(1) '<<<<<<<< ???? ADAPTER

nb = wsnew.range("AA2:AA500").specialcells(xlcelltypevisible).count
dl = wsral.cells(wsral.rows.count, 1).end(xlup).row '1è vide en colonne A de feuille 1 de ralentisseur

with wsnew
    .Rows("1:1").AutoFilter    
    .Range("$A$1:$AM$66").AutoFilter Field:=29, Criteria1:="<>"
    for i = 1 to nb
        wsral.Cells("A" & dl + i).value = .Range("C2:C500").specialcells(xlcelltypevisible)(i).value
        wsral.Cells("B" & dl + i).value = .Range("a2:a500").specialcells(xlcelltypevisible)(i).value
        wsral.Cells("D" & dl + i).value = .Range("h2:h500").specialcells(xlcelltypevisible)(i).value
        wsral.Cells("I" & dl + i).value = Range("AC2:AC500").specialcells(xlcelltypevisible)(i).value
        wsral.Cells("H" & dl + i).value = Range("B2:B500").specialcells(xlcelltypevisible)(i).value
        .Rows("1:1").AutoFilter
    next i
End with

set wbnew = nothing
Set wsnew = nothing
set wbral = nothing
set wsral = nothing

End Sub

Si les problèmes persistent, je regarderai le fichier...

Cdlt,

Merci pour le temps que tu passes pour chercher des solutions à mon problème.

J'ai essayer avec ce code, mais me le problème persiste. Pour info, j'ai effectivement des colonnes masqués dans le tableau source et j'ai modifié le numéro de la colonne pour le filtre (colonne 27) mais je ne pense pas que cela change quelques choses. J'ai vérifié et le filtre s'applique sur la bonne colonne.

Bon et bien, je reviens à la charge, cette fois en ne copiant que les valeurs si la cellule en AA n'est pas vide...

Il aurait fallu que je vois le fichier New 2020. Mais a priori, ça devrait fonctionner comme ça

Sub Att_ralentisseur()

dim wbral as workbook, wbnew as workbook
dim wsral as worksheet, wsnew as worksheet
Dim nb%, dl%, i%, n%

set wbnew = workbooks("New 2020.xlsm") 'thisworkbook
Set wsnew = wbnew.activesheet '<<<<< avec le nom de la feuille, c'est mieux
set wbral = Workbooks.Open("C:\Users\Desktop\Prépa Expédition COC\ATTESTATION Ralentisseur 2020 _ News.xlsm")
set wsral = wbral.sheets(1) '<<<<<<<< ???? ADAPTER

nb = wsnew.range("AA2:AA500").count
dl = wsral.cells(wsral.rows.count, 1).end(xlup).row '1è vide en colonne A de feuille 1 de ralentisseur

with wsnew
    .Rows("1:1").AutoFilter    
    .Range("$A$1:$AM$66").AutoFilter Field:=27, Criteria1:="<>" '<<< 66 ou 500 ???, colonne 27 (AA) ou 29 (AC)
    for i = 1 to nb
        if .Range("AA" & i).value <> "" then
            n = n + 1
            wsral.Cells("A" & dl + n).value = .Range("C" & i).value
            wsral.Cells("B" & dl + n).value = .Range("A" & i).value
            wsral.Cells("D" & dl + n).value = .Range("H" & i).value
            wsral.Cells("I" & dl + n).value = Range("AC" & i).value
            wsral.Cells("H" & dl + n).value = Range("B" & i).value
            .Rows("1:1").AutoFilter
        end if
    next i
End with

set wbnew = nothing
Set wsnew = nothing
set wbral = nothing
set wsral = nothing

End Sub

Bonsoir 3GB,

Encore merci pour le temps que tu passes sur mon sujet.

Malheureusement ça ne veut pas fonctionner:

Je n'avais pas réussi à joindre mon fichier News 2020 car il était trop volumineux. Je viens de le modifier pour l'alléger, en espérant que cela pourra t'aider.

Peux-tu réessayer ainsi :

Sub Att_ralentisseur()

Dim wbral As Workbook, wbnew As Workbook
Dim wsral As Worksheet, wsnew As Worksheet
Dim nb%, dl%, i%, n%

Set wbnew = ThisWorkbook
Set wsnew = wbnew.Sheets("Dossier de travail") '<<<<< avec le nom de la feuille, c'est mieux
Set wbral = Workbooks.Open("C:\Users\Desktop\Prépa Expédition COC\ATTESTATION Ralentisseur 2020 _ News.xlsm")
Set wsral = wbral.Sheets("Données") '<<<<<<<< ???? ADAPTER

nb = wsnew.Range("AA" & wsnew.Rows.Count).End(xlUp).Row
dl = wsral.Cells(wsral.Rows.Count, 1).End(xlUp).Row '1è vide en colonne A de feuille 1 de ralentisseur

With wsnew
    If .FilterMode Then .Rows(1).AutoFilter
    For i = 1 To nb
        If .Range("AA" & i).Value <> "" Then
            n = n + 1
            wsral.Range("A" & dl + n).Value = .Range("C" & i).Value
            wsral.Range("B" & dl + n).Value = .Range("A" & i).Value
            wsral.Range("D" & dl + n).Value = .Range("H" & i).Value
            wsral.Range("I" & dl + n).Value = .Range("AC" & i).Value
            wsral.Range("H" & dl + n).Value = .Range("B" & i).Value
        End If
    Next i
End With

Set wbnew = Nothing
Set wsnew = Nothing
Set wbral = Nothing
Set wsral = Nothing

End Sub

Je suis désolé, je ne peux pas tester aisément car j'ai un mac...

Normalement, ça devrait marcher, je pense que le problème provenait du filtre, qui, si je ne m'abuse, n'a pas d'intérêt compte tenu de l'opération.

Voici le fichier new :

Cdlt,

Malheureusement, ça bloque encore au même endroit.

J'ai essayé avec le fichier que tu m'a envoyé et recopiant le code mais j'ai le même résultat.

Merci pour ton aide.

Alala, c'est moi, j'ai laissé le cells originel de ton code que j'aurais dû remplacer par range et je n'ai pas fait attention...

Désolé. Mais là, alors là, ça devrait marcher .

Il faut voir mon message précédent que j'ai édité.

Super ça fonctionne !!! :-)

Il reste un petit problème, lors de la copie des données l'entête du tableau se copie également. Je suis désolé mais je ne sais pas comment faire. Comme tu dosi l'avoir compris, je ne connais pas grand chose à la rédaction des macros.

Merci encore!

Ahhh enfin !

Il suffit de modifier cette ligne :

For i = 1 To nb

par

For i = 2 To nb

Et tu peux même rajouter avant le with wsnew

if nb < 2 then exit sub

Cdlt,

Au top!!!

Je te remercie pour ton aide, ta disponibilité et ta patience.

Cela va vraiment m'aider au quotidien.

Merci 3GB!

Je t'en prie, je l'ai fait avec plaisir !

Bonne continuation alors