BONJOUR Le forum
le sujet a déjà été abordé mais je n'ai pas trouvé la solution recherchée aussi
de nouveau je vous sollicite pour adapter ce code
en vous remerciant
ce code me permet de transferer d'un classeur vers une feuille de ce même classeur sans problème
elle place les données les unes à la suite des autres en supprimant les lignes transférées
Si possible, je souhaite la meme chose mais en le transferant vers un autre classeur que je pourrai appellé " archive"
Dim MaxSource As Integer
Dim i As Integer
Dim LigneCible As Integer
Dim LigneSource As Integer
Dim Fin As Integer
Dim Quoi As String
'
Application.ScreenUpdating = False
Quoi = UCase(Sheets("PV").Range("F1").Value)
If Quoi = "" Then
MsgBox "Rien à copier !", vbCritical + vbOKOnly, "Attention..."
ElseIf Quoi = "INDIRECT" Then
' Initialisation de MaxSource à la dernière ligne contenant des
' données dans la feuille Source
MaxSource = Range("A65536").End(xlUp).Row
' Initialisation de LigneCible qui contiendra la dernière ligne
' vide de la feuille destination
LigneCible = Sheets("transfert INDIRECT").Range("A65535").End(xlUp).Row + 1
' Initialisation de la variable LigneSource qui contiendra le
' n° de la ligne en cours de vérification dans le classeur
' source.
LigneSource = 3
' on boucle pour trouver les valeurs correspondantes à
' sheets("archive").Range("F1") qui est devenue une formule (voir feuille
' source = archive)
Do While LigneSource <= MaxSource And UCase(Sheets("PV").Range("F1").Value) = Quoi
' I détermine la colonne où il faut saisir la lettre
If Quoi = UCase(Sheets("PV").Range("AP" & LigneSource).Value) Then
' A détermine la 1ère colonne et H la dernière colonne
Sheets("PV").Range("A" & LigneSource & ":AK" & LigneSource).EntireRow.Select
' on copie la sélection dans sheets("transfert") (feuille cible)
Selection.Copy Sheets("transfert").Range("A" & LigneCible)
Sheets("transfert INDIRECT").Rows(LigneCible - 1).Copy
Sheets("transfert INDIRECT").Rows(LigneCible).PasteSpecial Paste:=xlPasteFormats
' Après copie, on supprime la ligne entière dans la
' feuille source
Selection.EntireRow.SpecialCells(xlCellTypeConstants).ClearContents
' Puis on incrémente LigneCible car une ligne y a déjà été
' copiée, et on décrémente MaxSource car nous avons une
' ligne de moins dans la feuille source
LigneCible = LigneCible + 1
MaxSource = MaxSource - 1
Else
' Si on n'a pas trouvé la valeur "T" dans la cellule "F1"
' de la feuille source, on incrémente la var. LigneSource
LigneSource = LigneSource + 1
End If
Loop
End If
Range("A1").Select
Application.ScreenUpdating = True
le sujet a déjà été abordé mais je n'ai pas trouvé la solution recherchée aussi
de nouveau je vous sollicite pour adapter ce code
en vous remerciant
ce code me permet de transferer d'un classeur vers une feuille de ce même classeur sans problème
elle place les données les unes à la suite des autres en supprimant les lignes transférées
Si possible, je souhaite la meme chose mais en le transferant vers un autre classeur que je pourrai appellé " archive"
Dim MaxSource As Integer
Dim i As Integer
Dim LigneCible As Integer
Dim LigneSource As Integer
Dim Fin As Integer
Dim Quoi As String
'
Application.ScreenUpdating = False
Quoi = UCase(Sheets("PV").Range("F1").Value)
If Quoi = "" Then
MsgBox "Rien à copier !", vbCritical + vbOKOnly, "Attention..."
ElseIf Quoi = "INDIRECT" Then
' Initialisation de MaxSource à la dernière ligne contenant des
' données dans la feuille Source
MaxSource = Range("A65536").End(xlUp).Row
' Initialisation de LigneCible qui contiendra la dernière ligne
' vide de la feuille destination
LigneCible = Sheets("transfert INDIRECT").Range("A65535").End(xlUp).Row + 1
' Initialisation de la variable LigneSource qui contiendra le
' n° de la ligne en cours de vérification dans le classeur
' source.
LigneSource = 3
' on boucle pour trouver les valeurs correspondantes à
' sheets("archive").Range("F1") qui est devenue une formule (voir feuille
' source = archive)
Do While LigneSource <= MaxSource And UCase(Sheets("PV").Range("F1").Value) = Quoi
' I détermine la colonne où il faut saisir la lettre
If Quoi = UCase(Sheets("PV").Range("AP" & LigneSource).Value) Then
' A détermine la 1ère colonne et H la dernière colonne
Sheets("PV").Range("A" & LigneSource & ":AK" & LigneSource).EntireRow.Select
' on copie la sélection dans sheets("transfert") (feuille cible)
Selection.Copy Sheets("transfert").Range("A" & LigneCible)
Sheets("transfert INDIRECT").Rows(LigneCible - 1).Copy
Sheets("transfert INDIRECT").Rows(LigneCible).PasteSpecial Paste:=xlPasteFormats
' Après copie, on supprime la ligne entière dans la
' feuille source
Selection.EntireRow.SpecialCells(xlCellTypeConstants).ClearContents
' Puis on incrémente LigneCible car une ligne y a déjà été
' copiée, et on décrémente MaxSource car nous avons une
' ligne de moins dans la feuille source
LigneCible = LigneCible + 1
MaxSource = MaxSource - 1
Else
' Si on n'a pas trouvé la valeur "T" dans la cellule "F1"
' de la feuille source, on incrémente la var. LigneSource
LigneSource = LigneSource + 1
End If
Loop
End If
Range("A1").Select
Application.ScreenUpdating = True
