Je voudrais copier-coller une sélection multiple de LIGNES ENTIERES, d'un classeur vers un autre.
Private Sub Worksheet_SelectionChange(ByVal Target As Range) 'Pour Info: 'Seules les cellules de la colonne A1 peuvent être sélectionnées. 'Feuille1 protégée, Colonne A1 déverrouillée et sélection cellules déverrouillées uniquement 'Target = Sélection multiple des seules cellules en colonne A1 du classeur "source" For Each cell In Selection '(Reprise de la valeur de ligne Row de chaque cellue sélectionnée dans Mem, et "marquage" de la prise en compte par .Font) If cell.Font.Bold = False Then 'Si fonte standard (non sélectionné) cell.Font.Bold = True 'Fonte Gras cell.Font.ColorIndex = 3 'Fonte Rouge MemData.Mem = MemData.Mem & cell.Row & ":" & cell.Row & "," Else 'Si déjà sélectionné : annule la sélection MemData.Mem = Replace(MemData.Mem, cell.Row & ":" & cell.Row & ",", "") cell.Font.Bold = False 'Fonte Standard cell.Font.ColorIndex = 0 'Fonte Automatique End If Next End Sub
Public MemData As Etat Type Etat 'Activation de la Procédure de mémorisation de donnée Mem As String 'Mémoire Row (format texte) End Type Sub MultiRow() 'Copie GLOBALE de sélection multiple de différentes lignes entières, consécutives ou non 'Reprise des N° de lignes sélectionnées reportées If MemData.Mem = "" Then MsgBox "Aucune sélection!": Exit Sub MemData.Mem = Left(MemData.Mem, Len(MemData.Mem) - 1) 'Copiage de la sélection dans le classeur MultiExport Workbooks("MultiExport.xls").Sheets(1).Range(MemData.Mem).Copy 'Destination du collage dans le classeur1 'Dernière ligne non vide (accueil des copies dans le classeur1) Last = Workbooks("Classeur1").Sheets(1).Range("A65536").End(xlUp).Row 'Correctif pour la toute première ligne If Workbooks("Classeur1").Sheets(1).Range("A65536").End(xlUp).Value <> "" Then Last = Last + 1 'Collage de la sélection dans classeur MultiExport vers le classeur1 en première ligne vide ActiveSheet.Paste Destination:=Workbooks("Classeur1").Sheets(1).Range("A" & Last) 'Reset Font Classeur MultiExport Range("A:A").Font.Bold = False Range("A:A").Font.ColorIndex = 0 'Reset Font Classeur1 Workbooks("Classeur1").Sheets(1).Range("A:A").Font.Bold = False Workbooks("Classeur1").Sheets(1).Range("A:A").Font.ColorIndex = 0 'Reset de Mem MemData.Mem = "" End Sub
Je voudrais copier-coller une sélection multiple de LIGNES ENTIERES, d'un classeur vers un autre.
de manière simple,très facilement, à partir de Target
Vous n’avez pas trouvé la réponse que vous recherchez ?
Posez votre questionDim titi As Range Private Sub Worksheet_SelectionChange(ByVal Target As Range) Set titi = Target End Sub Private Sub CommandButton3_Click() If verifie_selection(titi) Then ajouter_a_feuille titi, ThisWorkbook.Worksheets("Feuil3") End If Set titi Nothing: encours True End Sub Private Function verifie_selection(ByVal titi As Range) As Boolean If Not titi Is Nothing Then ' et il faut vérifier ici que titi n'est composé que de lignes entières (et cela se fait en 1 seule ligne de code) 'et (et seulement si oui) ===>> ' il faut alors vérifier qu'aucun rang de cette sélection n'est jaune (déjà fait) 'et (et seulement alors) ===>> ' verifie_selection = True If Not titi.Address Like "*[A-Z]*" Then verifie_selection = True ' verifions que pas de jaune Dim a As Range For Each a In titi.Rows If a.Interior.ColorIndex 6 Then MsgBox "jaune": verifie_selection False: Exit Function Next End If End If End Function Private Sub ajouter_a_feuille(titi As Range, feuille As Worksheet) 'ici : '1)ajouter à la feuille de destination (toujours après la dernière ligne remplie) le contenu ' de chaque aire (area) de la plage titi '2) une fois 1) fait : mettre en jaune la ligne copiée (dans la feuille source) feuille.Range("A" & Rows.Count).Value = Chr(0) Dim a As Range For Each a In titi.Areas a.Copy Destination:=feuille.Range("A" & feuille.Range("A:A").SpecialCells(xlCellTypeBlanks).Row) a.Interior.ColorIndex = 6 Next feuille.Range("A" & Rows.Count).ClearContents End Sub
Tu le veux complet (donc avec code) ou seulement les commentaires (donc méthode)
If Not titi.Address Like "*[A-Z]*" Then
Private Sub Worksheet_Change(ByVal Target As Range) 'Agent Reset If Sheets("Data").Range("AS12").Value = 1 then Exit sub If Not Intersect(Target, Range("E48")) Is Nothing Then 'ça bloque dès la ligne ci-dessous, qui n'est plus exécutée!! Sheets("Data").Range("AS12").Value = 1 '% de Hauteur Totale par défaut If Sheets("Général").Range("K48").Value "+" Then Sheets("Général").Range("R38").Value 10 'Ascendant (10%) If Sheets("Général").Range("K48").Value "Q" Then Sheets("Général").Range("R38").Value 100 'Aucun (100%) If Sheets("Général").Range("K48").Value "," Then Sheets("Général").Range("R38").Value 90 'Descendant (90%) 'Mélange/Interface Sheets("Général").Range("K50").Value = "OUI" Sheets("Data").Range("AS12").Value = 0 End If
Après 8 jours, je n'arrive pas à mettre ta méthode en place: J'ai un problème avec
If Not titi.Address Like "*[A-Z]*" Then
If Not titi.Address Like "*[A-Z]*" Then
If Not titi.Address Like "*[A-Z]*" Then
'Erreur d'exécution '1004' 'Pas de cellules correspondantes For Each a In titi.Areas >> a.Copy Destination:=feuille.Range("A" & feuille.Range("A:A").SpecialCells(xlCellTypeBlanks).Row) a.Interior.ColorIndex = 6 Next
feuille.Range("A" & Rows.Count).Value = Chr(0)
If verifie_selection(titi) Then >> ajouter_a_feuille titi, ThisWorkbook.Worksheets("Feuil3") End If