transférer le contenu de plusieurs cellules

[kinel]

Bonjour le forum

je voudrai intégrer une macro qui me permette de transférer le contenu de plusieurs cellules vers d'autres sans modifier le format et seulement si la destination est vide

vous aurez une idée plus précise de ma recherche dans le fichier joint

Merci de votre aide

Kinel

 

[job75]

Re : transférer le contenu de plusieurs cellules

Re,

Ma version pour la permutation des plages sur sélection multiple de 2 cellules :

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
If Target.Areas.Count <> 2 Then Exit Sub
Dim P1 As Range, P2 As Range, t
Set P1 = Intersect(Target.Areas(1)(1).EntireRow, [C:H])
Set P2 = Intersect(Target.Areas(2)(1).EntireRow, [C:H])
If P1.Row < 3 Or P2.Row < 3 Then Exit Sub
Application.EnableEvents = False
If MsgBox("Permuter " & P1.Address(0, 0) & " et " & P2.Address(0, 0) & " ?", 4) = 6 _
  Then t = P1: P1 = P2.Value: P2 = t
Application.EnableEvents = True
End Sub

A+

 

[job75]

Re : transférer le contenu de plusieurs cellules

Re,

On peut se payer le luxe de colorer en rouge les plages à permuter :

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
If Target.Areas.Count <> 2 Then Exit Sub
Dim P1 As Range, P2 As Range, coul1&, coul2&, t
Set P1 = Intersect(Target.Areas(1)(1).EntireRow, [C:H])
Set P2 = Intersect(Target.Areas(2)(1).EntireRow, [C:H])
If P1.Row < 3 Or P2.Row < 3 Then Exit Sub
coul1 = P1(1).Interior.Color: coul2 = P2(1).Interior.Color
Application.EnableEvents = False
Union(P1, P2).Interior.ColorIndex = 3 'rouge
If MsgBox("Permuter " & P1.Address(0, 0) & " et " & P2.Address(0, 0) & " ?", 4) = 6 _
  Then t = P1: P1 = P2.Value: P2 = t
P1.Interior.Color = coul1: P2.Interior.Color = coul2
Application.EnableEvents = True
End Sub

Bonne fin de soirée et A+

 

[kinel]

Re : transférer le contenu de plusieurs cellules

Bonjour à tous
très fort Job75, avec le surlignage rouge ça le fait

mais le projet devra être utilisé par plusieurs personnes dont certaines un peu "allergiques" au clavier
je crains que la sélection multiple les dépasse un peu

j'ai donc choisi ce code le code ci dessous mais il faudrait le compléter pour que tout fonctionne bien

1 il faudrait limiter l'action de la commande aux cellules ("C3:H62")
2 Chaque ligne sera liée à une feuille qui portera le nom du numéro de chambre (en colonne B), il faudrait donc modifier aussi le nom de la feuille liée de façon à ce que les données de la chambre 101 aillent en chambre 102 s'il y a un mouvement.

je crois qu'après le projet sera quasi terminé
merci de votre aide
Kinel

Option Explicit
Dim NLigEch As Long

Private Sub Worksheet_BeforeRightClick(ByVal Target As Range, Cancel As Boolean)
Cancel = True
If MsgBox("voulez vous poursuivre la procédure ?", _
vbOKCancel + vbInformation, "Changement de chambre") = vbCancel Then Exit Sub
Dim T() As Variant
If NLigEch > 0 Then
If Target.Row <> NLigEch Then
Application.EnableEvents = False
T = Me.[C:H].Rows(NLigEch).Value
Me.[C:H].Rows(NLigEch).Value = Me.[C:H].Rows(Target.Row).Value
Me.[C:H].Rows(Target.Row).Value = T
Application.EnableEvents = True
End If
NLigEch = 0
Else: NLigEch = Target.Row: End If
Cancel = True
End Sub

 

[job75]

Re : transférer le contenu de plusieurs cellules

Bonjour kinel, le forum,

Alors si l'on n'aime pas la sélection multiple, voyez le double-clic :

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
If Target.Row < 3 Or Target.Row > 62 Then Exit Sub
Dim P2 As Range, F2 As Worksheet, coul2&, t
Cancel = True
On Error Resume Next 'si une feuille F1 ou F2 n'existe pas
If P1 Is Nothing Then
  Set P1 = Intersect(Target.EntireRow, [C:H])
  Set F1 = Nothing
  Set F1 = Sheets(CStr(P1(0)))
  If F1 Is Nothing Then Set P1 = Nothing: Exit Sub
  coul1 = P1(1).Interior.Color: P1.Interior.ColorIndex = 3
End If
Set P2 = Intersect(Target.EntireRow, [C:H])
Set F2 = Sheets(CStr(P2(0)))
If F2 Is Nothing Or P1.Row = P2.Row Then Exit Sub
coul2 = P2(1).Interior.Color: P2.Interior.ColorIndex = 3
If MsgBox("Permuter " & P1.Address(0, 0) & " et " & P2.Address(0, 0) & " ?", 4) = 6 Then
  Application.EnableEvents = False
  t = P1: P1 = P2.Value: P2 = t
  F1.Name = "   ": F2.Name = CStr(P1(0)): F1.Name = CStr(P2(0))
  Application.EnableEvents = True
End If
P1.Interior.Color = coul1: P2.Interior.Color = coul2
Set P1 = Nothing 'RAZ
End Sub

Le double-clic n'a pas d'effet si la feuille (chambre) mentionnée en colonne B n'existe pas.

Les variables P1, F1, coul1 sont mémorisées dans Module1 :

Public P1 As Range, F1 As Worksheet, coul1& 'mémorisation

Et dans ThisWorkbook :

Private Sub Workbook_BeforeClose(Cancel As Boolean)
If Not P1 Is Nothing Then P1.Interior.Color = coul1
End Sub

Fichier joint.

A+

 

[kinel]

Re : transférer le contenu de plusieurs cellules

Bonjour à tous

Alors là ! très très fort Job75 !

je vais essayer d'intégrer tout ça à mon projet
en espérant qu'il n'y ait pas de conflit avec le contenu actuel

merci

Kinel

 

[job75]

Re : transférer le contenu de plusieurs cellules

Re,

C'est mieux avec une Workbook_BeforeSave dans ThisWorkbook :

Private Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, Cancel As Boolean)
If Not P1 Is Nothing Then P1.Interior.Color = coul1: Set P1 = Nothing
End Sub

Fichier (2).

A+

 

[job75]

Re : transférer le contenu de plusieurs cellules

Re,

Ah, un détail, il manquait un Set F1 = Nothing, je corrige les fichiers (1) et (2).

A+

 

[kinel]

Re : transférer le contenu de plusieurs cellules

re,

j'ai intégré au projet global, l'opération de transfert fonctionne
mais j'ai un autre souci :

sur les fiches 101, 102.... les cellules du nom, prénom, n°de chb, date entrée et motif sont des cellules complétées avec =feuil1!D3 dans la barre de formule. Elles ne suivent donc pas le déplacement
pour le reste de la fiche pas de souci les codes choisis sont bons et suivent le déplacement

voici le classeur complet

 

[job75]

Re : transférer le contenu de plusieurs cellules

Re,

Pff... Vous nous distillez les informations au compte-goutte...

sur les fiches 101, 102.... les cellules du nom, prénom, n°de chb, date entrée et motif sont des cellules complétées avec =feuil1!D3 dans la barre de formule. Elles ne suivent donc pas le déplacement

Eh bien il ne faut pas qu'il y ait de formules mais des valeurs, un point c'est tout.

Supprimez les formules de ces cellules par un Copier - Collage spécial - Valeurs.

Et quand vous créez une feuille, faites la même chose, ce n'est pas plus compliqué.

A+

 

[job75]

Re : transférer le contenu de plusieurs cellules

Re,

Par contre en H2, comme le n° de chambre est toujours le nom de la feuille, il faut cette formule :

=STXT(CELLULE("filename";H2);TROUVE("]";CELLULE("filename";H2))+1;31)

A+

 

[kinel]

Re : transférer le contenu de plusieurs cellules

re
cette fois je crois bien que tout fonctionne à merveille
juste les créations de feuilles 101 102... pour les 60 chambres et le tour est joué

sans le forum j'y serai jamais arrivé
merci à tous et particulièrement aux gens très doués qui m'ont fait des réponses de très haut niveau !

Kinel

 

[job75]

Re : transférer le contenu de plusieurs cellules

Re,

Si l'on modifie des valeurs en Feuil1 il faut que dans les feuilles des chambres il y ait des formules.

Comme déjà dit en H2 :

=STXT(CELLULE("filename";H2);TROUVE("]";CELLULE("filename";H2))+1;31)

En B2 :

=SI(NB.SI(Feuil1!$B:$B;$H$2);RECHERCHEV(SI(ESTNUM(-$H$2);--$H$2;$H$2);Feuil1!$B:$H;3;0);"")

En B3 :

=SI(NB.SI(Feuil1!$B:$B;$H$2);RECHERCHEV(SI(ESTNUM(-$H$2);--$H$2;$H$2);Feuil1!$B:$H;4;0);"")

En D2 :

=SI(NB.SI(Feuil1!$B:$B;$H$2);RECHERCHEV(SI(ESTNUM(-$H$2);--$H$2;$H$2);Feuil1!$B:$H;7;0);"")

En P2 (date) :

=SI(NB.SI(Feuil1!$B:$B;$H$2);RECHERCHEV(SI(ESTNUM(-$H$2);--$H$2;$H$2);Feuil1!$B:$H;2;0);"")

En C3 :

=SI(NB.SI(Feuil1!$B:$B;$H$2);RECHERCHEV(SI(ESTNUM(-$H$2);--$H$2;$H$2);Feuil1!$B:$H;6;0);"")

Fichier joint.

Nota : vous n'aviez pas corrigé la macro en Feuil1 avec comme je l'ai dit Set F1 = Nothing.

A+

 

[kinel]

Re : transférer le contenu de plusieurs cellules

ho !
ça va accélérer les choses ces formules ! merci

pour le Set F1 = Nothing je l'avait bien modifié mais après le transfert ne fonctionnait plus

pouvez vous me préciser le lieu de ce changement ?

Merci

kinel

 

[job75]

Re : transférer le contenu de plusieurs cellules

Re,

pouvez vous me préciser le lieu de ce changement ?

Bah copiez bêtement toute ma dernière macro.

Set F1 = Nothing n'est qu'en un seul endroit, suffit de lire.

A+

 

[job75]

Re : transférer le contenu de plusieurs cellules

Re,

Pas tout à fait fini avec la macro en Feuil1

On a bien sûr remarqué que la permutation des plages bouleverse l'ordre des feuilles chambres.

Pour y remédier il faut déplacer les 2 feuilles chambres en modifiant comme suit :

If MsgBox("Permuter " & P1.Address(0, 0) & " et " & P2.Address(0, 0) & " ?", 4) = 6 Then
  Application.ScreenUpdating = False
  Application.EnableEvents = False
  t = P1: P1 = P2.Value: P2 = t
  F1.Name = "   ": F2.Name = CStr(P1(0)): F1.Name = CStr(P2(0))
  Set F1 = Sheets(F1.Index - 1): Set F2 = Sheets(F2.Index - 1)
  Sheets(CStr(P1(0))).Move After:=F1: Sheets(CStr(P2(0))).Move After:=F2
  Me.Activate
  Application.EnableEvents = True
End If

Fichier (2).

A+