"couper / coller" validé par un bouton

[dj_fdl]

Bonjour,
bon j'ai lu une bonne centaine de discussions tout forum confondu et je pense etre face a celui qui m'apportera un maximum d'aide ...

MON PROBLEME :
je dois couper certaines cellules d'un tableau situé dans la feuille 1 et les coller dans une feuille 2 (à l'aide d'un bouton "VALIDER TRANSFERT" situé en feuille 1).

la condition unique pour couper ces cellules est un "X" dans la ligne concernée par ces cellules.

exemple :
en feuille 1, je veux historiser les cellules A1,A3 et A4. si et seulement si en A5 j'ai un "X"
Une fois ce "X" tapé, je valide cette ligne à couper en cliquant sur un bouton.
la ligne alors coupée passe sur une feuille 2.

toutes les lignes coupées (concernées donc par des "X") sont collée en feuille 2.

pour chaque colle en feuille 2, le X de la feuille 1 disparait
et les lignes sont collées systématiquement AU DESSUS des précédentes...

vous voyez?

ci-joint ce petit tableau...

merci pour votre aide

 

[skoobi]

Re : "couper / coller" validé par un bouton

Bonjour dj_fdl,

l'exemple que tu mets dans ton message ne colle pas avec le tableau du fichier, donc difficile de te suivre. On peut faire des suppositions mais bon...

 

[PMO2]

Re : "couper / coller" validé par un bouton

Bonjour,

Une piste avec le code suivant où il faudra adapter les constantes à votre usage (cernées par des ###)

'### Constantes à adapter à votre usage ###
Const SOURCE As String = "Feuil1"
Const DEST As String = "Feuil2"
'##########################################

Sub Transfert_pmo()
Dim S1 As Worksheet
Dim S2 As Worksheet
Dim R1 As Range
Dim R2 As Range
Dim var
Dim i&
Dim j&
Dim nbRow&
On Error GoTo Erreur
Application.ScreenUpdating = False
Set S1 = ActiveWorkbook.Sheets(SOURCE)
Set S2 = ActiveWorkbook.Sheets(DEST)
Set R1 = S1.Range("a1:e" & S1.[a65536].End(xlUp).Row & "")
var = R1
For i& = 2 To UBound(var, 1)
  If LCase(var(i&, 5)) = "x" Then
    nbRow& = nbRow& + 1
    If R2 Is Nothing Then
      Set R2 = S1.Range(S1.Cells(i&, 1), S1.Cells(i&, 1))
      For j& = 3 To 4
        Set R2 = Application.Union(R2, _
            S1.Range(S1.Cells(i&, j&), S1.Cells(i&, j&)))
      Next j&
    Else
      For j& = 1 To 4
        If j& <> 2 Then
          Set R2 = Application.Union(R2, _
              S1.Range(S1.Cells(i&, j&), S1.Cells(i&, j&)))
        End If
      Next j&
  
    End If
  End If
Next i&
If R2 Is Nothing Then Exit Sub
With S2
  .Activate
  .Rows("2:" & nbRow& + 1 & "").Insert Shift:=xlDown
  R2.Copy
  .[a2].Select
  .Paste
  .[a1].Select
End With
S1.Activate
Erreur:
Application.ScreenUpdating = True
Application.CutCopyMode = False
If Err <> 0 Then MsgBox "Erreur " & Err.Number & vbCrLf & Err.Description
End Sub

Je n'ai pas traité le cas où vous réitérez l'opération ayant pour conséquence de
réinscrire des personnes déjà inscrites. Mais, bien sûr, on peut programmer pour l'éviter.

Cordialement.

PMO
Patrick Morange

 

[dj_fdl]

Re : "couper / coller" validé par un bouton

merci beaucoup ...

je vous envoie le VRAI fichier dans lequel je veux effectuer cette appli.

Mon tableau fait 500 lignes au final
ma feuille 1 se nomme "matériel"
ma feuille 2 se nomme "Entrées, Sorties matériels"

pour résumer, je voudrais couper les cellules A.B.F.R.S.T.U.V de la ligne concernée par un "X" (colonne Y). quelque soit la ligne.
si plusieurs "X" sont tapés, bien sur, toutes les lignes sont coupées et se collent en feuille 2.
est ce que les formules restent après le coupage? j'ai besoin qu'elle restent...

 

[PMO2]

Re : "couper / coller" validé par un bouton

Bonjour,

Apparemment, si vous modifiez votre dernier message plutôt que d'en créer un nouveau, nous n'en sommes pas averti bien qu'étant abonné à cette discussion.
Ce n'est que par hasard que je découvre votre message modifié.
Il semble qu'il faille obligatoirement créer un nouveau message pour que les différents intervenants en soit averti.

PMO
Patrick Morange

 

[PMO2]

Re : "couper / coller" validé par un bouton

Bonjour,

Votre demande ayant évolué, voici un nouveau code qui conserve les formules.

'### Constantes à adapter à votre usage ###
Const SOURCE As String = "matériel"
Const DEST As String = "Entrées, Sorties matériels"
'##########################################

Sub Transfert_pmo2()
Dim S1 As Worksheet
Dim S2 As Worksheet
Dim tempo As Worksheet
Dim R As Range
Dim var
Dim i&
Dim nbRow&
Dim ColDelete
'### Colonnes à virer (à adapter) ###
ColDelete = Array("W:Y", "G:Q", "C:E")
'####################################
On Error GoTo Erreur
Application.ScreenUpdating = False
Set S1 = ActiveWorkbook.Sheets(SOURCE)
Set S2 = ActiveWorkbook.Sheets(DEST)
Set R = S1.Range("a1:z" & S1.[a65536].End(xlUp).Row & "")
var = R
Set tempo = Sheets.Add
For i& = 2 To UBound(var, 1)
  If LCase(var(i&, 25)) = "x" Then
    nbRow& = nbRow& + 1
    S1.Rows(i&).Copy
    tempo.Range("a" & nbRow& & "").Select
    tempo.Paste
    S1.Range("y" & i& & "") = ""
  End If
Next i&
If nbRow& = 0 Then Exit Sub
For i& = LBound(ColDelete) To UBound(ColDelete)
  tempo.Columns(ColDelete(i&)).Delete
Next i&
With S2
  .Activate
  .Rows("2:" & nbRow& + 1 & "").Insert Shift:=xlDown
  tempo.UsedRange.Copy
  .[a2].Select
  .Paste
  .[a1].Select
End With
Application.DisplayAlerts = False
tempo.Delete
S1.Activate
Erreur:
Application.ScreenUpdating = True
Application.CutCopyMode = False
Application.DisplayAlerts = True
If Err <> 0 Then MsgBox "Erreur " & Err.Number & vbCrLf & Err.Description
End Sub

Cordialement.

PMO
Patrick Morange