Copier des ligne discontinues et variables dans un autre classeur ouvert

Boostez vos compétences Excel avec notre communauté !

Rejoignez Excel Downloads, le rendez-vous des passionnés où l'entraide fait la force. Apprenez, échangez, progressez – et tout ça gratuitement ! 👉 Inscrivez-vous maintenant !

lizanne828

XLDnaute Nouveau
Bonjour,

Mon problème est dans le titre...

J'ai une macro dans un fichier de départ, qui doit copier toutes les lignes dont la colonne B est non vide, et qui va coller ces lignes à la suite d'autres lignes dans un autre fichier "TBG Vierge", feuille "Import" qui est ouvert.

Résultat des courses il ne me copie que la dernière ligne de la boucle, il ne semble pas garder en mémoire toutes les autres... Voici mon code:


Dim d As Integer
With ActiveSheet

'la colonne non vide doit être sur la colonne B


For d = .Range("B" & .Rows.Count).End(xlUp).Row To 1 Step -1

If .Range("B" & d).Value <> "" Then
.Rows(d).Copy
End If
Next d
End With

Windows("TBG vierge.xlsm").Activate
Sheets("Import").Activate

With ActiveSheet
Dim derligne As Integer
derligne = .Range("B999999").End(xlUp).Row



Dim l As Integer
l = derligne + 1


Rows(l).Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
 
Re : Copier des ligne discontinues et variables dans un autre classeur ouvert

Bonsoir lizanne828,

En supposant qu'il y a une 1ère ligne pour les titres non copiée :

Code:
Sub Copie()
Dim Wb As Workbook, F As Worksheet
On Error Resume Next
Set Wb = Workbooks("TBG vierge.xlsm")
If Wb Is Nothing Then MsgBox "'TBG vierge.xlsm' n'est pas ouvert", 48: Exit Sub
Set F = Wb.Worksheets("Import")
If F Is Nothing Then MsgBox "La feuille 'Import' n'existe pas", 48: Exit Sub
On Error GoTo 0
ActiveSheet.UsedRange.EntireRow.Offset(1).Copy _
F.Range("A" & F.Range("B" & F.Rows.Count).End(xlUp).Row + 1)
F.UsedRange.EntireRow.Sort F.[B1], xlAscending, Header:=xlYes 'tri croissant
On Error Resume Next 's'il n'y a pas de cellules vides en colonne B
F.Range("B2:B" & F.Rows.Count).SpecialCells(xlCellTypeBlanks).EntireRow.Delete
F.Activate 'facultatif
End Sub
Vous remarquerez que la copie se fait en bloc, sans aucune boucle.

Le tri permet d'accélérer la suppression des lignes.

Bonne fin de soirée et A+
 
Re : Copier des ligne discontinues et variables dans un autre classeur ouvert

Re,

Si maintenant, comme vous avez tenté de le faire, il ne faut copier que les valeurs :

Code:
Sub Copie()
Dim Wb As Workbook, F As Worksheet
On Error Resume Next
Set Wb = Workbooks("TBG vierge.xlsm")
If Wb Is Nothing Then MsgBox "'TBG vierge.xlsm' n'est pas ouvert", 48: Exit Sub
Set F = Wb.Worksheets("Import")
If F Is Nothing Then MsgBox "La feuille 'Import' n'existe pas", 48: Exit Sub
On Error GoTo 0
Application.ScreenUpdating = False
ActiveSheet.UsedRange.EntireRow.Offset(1).Copy
F.Range("A" & F.Range("B" & F.Rows.Count).End(xlUp).Row + 1).PasteSpecial xlPasteValues
F.UsedRange.EntireRow.Sort F.[B1], xlAscending, Header:=xlYes 'tri croissant
On Error Resume Next 's'il n'y a pas de cellules vides en colonne B
F.Range("B2:B" & F.Rows.Count).SpecialCells(xlCellTypeBlanks).EntireRow.Delete
Application.Goto F.[A1], True 'facultatif
End Sub
A+
 
Re : Copier des ligne discontinues et variables dans un autre classeur ouvert

Pardon pour le temps de cogitage!
J'ai effectivement essayé votre code qui marche, mais j'avais un problème de format. Mis à part cela, votre code est très complet, clair, précis, rapide d'exécution, merci pour votre aide!

Entre-temps, comme j'étais persuadée que mon problème ainsi que bcp d'autres de ce style que j'ai régulièrement pouvaient se résoudre à l'aide de tables, j'ai planché sur les tableaux en VBA, ce qui m'a permis d'y arriver aussi avec cette méthode, même si je sais que mon code n'est sans doute pas optimisé et peut-être un peu tordu.

Je le mets au cas où, si ça peut aider quelqu'un, ça fera 2 réponses qui fonctionnent.

Sub Exporter()

Dim d As Integer
Dim a As Integer
With ActiveSheet


Dim i As Integer
Dim j As Integer


Dim tabl1
Dim tabl2(1000, 16) As String

a = Range("P1").Value


tabl1 = Range("A33: P1032").Value
End With



Windows("TBG vierge.xlsm").Activate
Sheets("Import").Activate
With ActiveSheet
Dim derligne As Integer
d = 0



derligne = .Range("B999999").End(xlUp).Row + 1
For Each cel In Range("A1:A" & derligne)
If cel.Value = a Then
MsgBox "feuille déjà copiée"
Exit Sub
End If
Next cel
For j = 1 To 1000
If tabl1(j, 2) <> "" Then
For i = 1 To 16

tabl2(d, i - 1) = tabl1(j, i)

Next i
d = d + 1
End If
Next j
End With

Range(Cells(derligne, 1), Cells(derligne + 1000, 16)).Value = tabl2

End sub

En tous cas un grand merci pour votre super travail qui m'a beaucoup aidée, et que je pourrai réutiliser aussi dans de nombreux cas, où je me compliquais la vie comme d'hab 🙂 ...
 
- Navigue sans publicité
- Accède à Cléa, notre assistante IA experte Excel... et pas que...
- Profite de fonctionnalités exclusives
Ton soutien permet à Excel Downloads de rester 100% gratuit et de continuer à rassembler les passionnés d'Excel.
Je deviens Supporter XLD

Discussions similaires

  • Question Question
Microsoft 365 worksheet_change
Réponses
29
Affichages
483
Réponses
5
Affichages
244
  • Question Question
Microsoft 365 Export données
Réponses
4
Affichages
651
Retour