Copier des ligne discontinues et variables dans un autre classeur ouvert

[lizanne828]

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

 

[job75]

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 :

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+

 

[job75]

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 :

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+

 

[lizanne828]

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 ...