Fusionner 2 codes VBA

[Amilo]

Bonjour le forum,

J'essaye d'adapter le code de job75 qui a bien voulu m'aider dans mon précédent fil et que je remercie encore,
Le code initial renvoyait des valeurs dans la plage C et D par rapport à la sélection de la cellule A1,

J'ai légèrement modifié pour le tester sur la plage K:L en fonction de la cellule I1 et cela marche,

Par contre, je n'arrive pas à fusionner les 2 codes pour qu'ils fonctionnent en simultané,

P.S 😛ar ailleurs, je ne comprends pas trop l'utilité de cette variable en rouge dans l'instruction ci-dessous :
Peut-on supprimer cette partie ?

Dim dest As Range, source As Range, r As Range, h&


Merci d'avance pour votre aide

Cordialement

 

[Staple1600]

Re : Fusionner 2 codes VBA

Bonsoir à tous


Amilo
Il est préférable de rester dans le fil initial plutôt que d'ouvrir un second fil.
https://www.excel-downloads.com/threads/extraire-donnees-dun-tableau-en-vba.231822/

 

[Amilo]

Re : Fusionner 2 codes VBA

Bonjour Staple1600,

J'ai effectivement hésité avant d'ouvrir un nouveau fil pour ne pas trop surcharger le précédent,

Cordialement

 

[Staple1600]

Re : Fusionner 2 codes VBA

Re

Amilo
L'habitude sur le forum est de rester dans le fil initial et d'éviter les fils doublons pour une même question.
(Mais cela tu le sais déjà étant inscrit depuis 2009 et parce que je te l'ai déjà dit dans un autre de tes fils 😉)

 

[Amilo]

Re : Fusionner 2 codes VBA

Désolé,

Je le note pour la prochaine fois, il s'agit du même fichier, même code et donc devant rester effectivement dans le même fil,

Cordialement

 

[job75]

Re : Fusionner 2 codes VBA

Bonjour Amilo, JM,

P.S 😛ar ailleurs, je ne comprends pas trop l'utilité de cette variable en rouge dans l'instruction ci-dessous :
Peut-on supprimer cette partie ?

Dim dest As Range, source As Range, r As Range, h&

Oui bien sûr, la variable r servait dans une macro antérieure à celle-là.

Si l'on veut traiter en même temps les données des cellules A1 et I1 :

Private Sub Worksheet_Change(ByVal Target As Range)
If Intersect(Target, [A1,I1]) Is Nothing Then Exit Sub
Dim dest As Range, source As Range, h&
'---initialisation---
Set dest = [K2] '1ère cellule, à adapter
With Feuil1 'CodeName
  Set source = .[E:F] 'colonnes à adapter
  Set source = Intersect(source, .UsedRange.EntireRow)
End With
'---copie---
Application.ScreenUpdating = False
source.Copy dest 'pour les formats
Set dest = dest.Resize(source.Rows.Count, source.Columns.Count)
dest = source.Value 'copie les valeurs
'---traitement des données---
On Error Resume Next 's'il n'y a pas de SpecialCells
dest.Replace [A1], "#N/A", xlWhole
dest.Replace [I1], "#N/A", xlWhole
With dest.SpecialCells(xlCellTypeConstants, 16)
  .Clear
  With Intersect(.EntireRow, dest)
     h = Intersect(.Cells, dest.Columns(1)).Count
     .Copy dest(dest.Rows.Count + 1, 1) 'zone tampon sous le tableau
  End With
End With
dest.Offset(dest.Rows.Count).Resize(h).Copy dest(1)
dest.Offset(h).Resize(Rows.Count - h - dest.Row + 1).Delete xlUp
End Sub

Fichier joint.

A+

 

[job75]

Re : Fusionner 2 codes VBA

Re,

Où l'on retrouve la variable r :

Private Sub Worksheet_Change(ByVal Target As Range)
Dim r As Range, dest As Range, source As Range, h&
Set r = [A1,E1,I1] 'plage à adapter
If Intersect(Target, r) Is Nothing Then Exit Sub
'---initialisation---
Set dest = [K2] '1ère cellule, à adapter
With Feuil1 'CodeName
  Set source = .[E:F] 'colonnes à adapter
  Set source = Intersect(source, .UsedRange.EntireRow)
End With
'---copie---
Application.ScreenUpdating = False
source.Copy dest 'pour les formats
Set dest = dest.Resize(source.Rows.Count, source.Columns.Count)
dest = source.Value 'copie les valeurs
'---traitement des données---
On Error Resume Next 's'il n'y a pas de SpecialCells
For Each r In r
  dest.Replace r, "#N/A", xlWhole
Next
With dest.SpecialCells(xlCellTypeConstants, 16)
  .Clear
  With Intersect(.EntireRow, dest)
     h = Intersect(.Cells, dest.Columns(1)).Count
     .Copy dest(dest.Rows.Count + 1, 1) 'zone tampon sous le tableau
  End With
End With
dest.Offset(dest.Rows.Count).Resize(h).Copy dest(1)
dest.Offset(h).Resize(Rows.Count - h - dest.Row + 1).Delete xlUp
End Sub

Fichier (2).

A+

 

[Amilo]

Re : Fusionner 2 codes VBA

Bonsoir job75,

Merci pour votre réponse, malheureusement dans votre message 6, la cellule A1 agît sur la 2ème plage L:M alors que je souhaitais avoir les valeurs dans la plage C et D de manière à avoir 2 listes en vis à vis (C D et K:L)

Cordialement

 

[job75]

Re : Fusionner 2 codes VBA

Re,

Vous n'aviez pas dit que vous vouliez 2 listes, mais pas de problème voyez ce fichier (3) :

Private Sub Worksheet_Change(ByVal Target As Range)
Dim r As Range, source As Range, dest As Range, h&
Set r = Intersect(Target, [A1,I1]) 'plage à adapter
If r Is Nothing Then Exit Sub
'---initialisation---
With Feuil1 'CodeName
  Set source = .[E:F] 'colonnes à adapter
  Set source = Intersect(source, .UsedRange.EntireRow)
End With
Application.ScreenUpdating = False
On Error Resume Next 's'il n'y a pas de SpecialCells
For Each r In r 'si entrées multiples
  Set dest = r(2, 3) '1ère cellule, décalages à adapter
  '---copie---
  source.Copy dest 'pour les formats
  Set dest = dest.Resize(source.Rows.Count, source.Columns.Count)
  dest = source.Value 'copie les valeurs
  '---traitement des données---
  dest.Replace r, "#N/A", xlWhole
  With dest.SpecialCells(xlCellTypeConstants, 16)
    .Clear
    With Intersect(.EntireRow, dest)
      h = 0
      h = Intersect(.Cells, dest.Columns(1)).Count
      .Copy dest(dest.Rows.Count + 1, 1) 'zone tampon sous le tableau
    End With
  End With
  dest.Offset(dest.Rows.Count).Resize(h).Copy dest(1)
  dest.Offset(h).Resize(Rows.Count - h - dest.Row + 1).Delete xlUp
Next
End Sub

Edit : ajouté h = 0.

A+

 

[Amilo]

Re : Fusionner 2 codes VBA

Re,
Merci beaucoup job75 pour toute votre aide, cela fonctionne très bien,
Désolé, je n'avais effectivement pas été très précis dans ma 1ère demande,

Bonne nuit à toutes et à tous

Cordialement