Microsoft 365 Combiner RechercheV et saisie manuelle

Nico2Nice

XLDnaute Nouveau
Bonjour à toutes et à tous,

Je bloque sur le fait d'arriver à combiner de la saisie manuelle avec de la saisie automatique.

Je m'explique : j'ai une base de données avec des adhérents, ils sont soit "INDIV" soit"COPRO".
S'ils sont type "COPRO" pas besoin de saisir les différents champs adresse : RECHERCHEV fait le job.
S'ils sont type "INDIV" j'ai besoin de reprendre la main et compléter moi même les champs...sans écraser les formules.

Je sais que la soluc' passe par VBA, mais encore un peu vert dans la programmation, je suis preneur d'un coup de pouce !

D'avance merci
 

Pièces jointes

  • Fichier_test_Nico.xlsm
    16.3 KB · Affichages: 20
Solution
Bonsoir Nico2Nice,

Pour les noms propres et les majuscules il suffit d'ajouter ce code dans la Worksheet_Change :
VB:
    '---noms propres et majuscules---
    R.Cells(5) = Application.Proper(R.Cells(5))
    R.Cells(6) = UCase(R.Cells(6))
    R.Cells(8) = Application.Proper(R.Cells(8))
    R.Cells(9) = UCase(R.Cells(9))
Fichier (2).

A+

Pounet95

XLDnaute Occasionnel
Bonsoir,
Copier ce code dans l'évènement Worksheet_Change de la feuille concernée : Feuil1(BASE)
Ajouter dans la liste des Copro la valeur INDIV

Ca le fait ?
Claude alias Pounet95

VB:
Option Explicit

Private Sub Worksheet_Change(ByVal Target As Range)
    'valeur dans la colonne des Nom Copro
    If Not Intersect(Columns(4), Target) Is Nothing Then
        Application.EnableEvents = False
        If Target = "INDIV" Then
            'aucune formule en colonnes
            Range(Cells(Target.Row, 5), Cells(Target.Row, 10)) = ""
        Else
            Formules_Recherche Target.Row
        End If
    End If
    Application.EnableEvents = True
End Sub

Private Sub Formules_Recherche(numlig As Long)
    'Ecrit les formules de recherche pour la ligne concernée passée en paramètre
    Range("E" & numlig).FormulaR1C1 = "=IF([@[Nom Corpro]]<>""INDIV"",IFERROR(VLOOKUP([@[Nom Corpro]],mes_copros,2,FALSE),""""),"""")"
    Range("F" & numlig).FormulaR1C1 = "=IFERROR(VLOOKUP([@[Nom Corpro]],mes_copros,3,FALSE),"""")"
    Range("G" & numlig).FormulaR1C1 = "=IFERROR(VLOOKUP([@[Nom Corpro]],mes_copros,4,FALSE),"""")"
    Range("H" & numlig).FormulaR1C1 = "=IFERROR(VLOOKUP([@[Nom Corpro]],mes_copros,5,FALSE),"""")"
    Range("I" & numlig).FormulaR1C1 = "=IFERROR(VLOOKUP([@[Nom Corpro]],mes_copros,6,FALSE),"""")"
    Range("J" & numlig).FormulaR1C1 = "=IFERROR(VLOOKUP([@[Nom Corpro]],mes_copros,7,FALSE),"""")"
End Sub
 

job75

XLDnaute Barbatruc
Bonsoir Nico2Nice, Pounet95,

Voyez le fichier joint et ces 2 macros dans le code de la feuille "Base" :
VB:
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
[Tableau1].Columns(4).Validation.Delete 'RAZ
If UCase(Cells(ActiveCell.Row, 1)) = "COPRO" And Not Intersect(ActiveCell, [Tableau1].Columns(4)) Is Nothing _
    Then ActiveCell.Validation.Add xlValidateList, Formula1:="=" & [Tableau3].Columns(1).Address(External:=True)
End Sub

Private Sub Worksheet_Change(ByVal R As Range)
If Intersect(R, [Tableau1]) Is Nothing Then Exit Sub
Dim T As Range, i As Variant
Set R = Intersect(R.EntireRow, [Tableau1]).Rows
Set T = [Tableau3]
Application.ScreenUpdating = False
Application.EnableEvents = False 'désactive les évènements
For Each R In R 'si entrées ou effacements multiples
    If UCase(R.Cells(1)) = "COPRO" Then
        i = Application.Match(R.Cells(4), T.Columns(1), 0)
        If IsError(i) Then
            R.Cells(4).Resize(, 7) = "" 'RAZ
        Else
            R.Cells(5).Resize(, 6) = T(i, 2).Resize(, 6).Value
        End If
    End If
Next
Application.EnableEvents = True 'réactive les évènements
End Sub
La 1ère crée les listes de validation en colonne D, la 2ème entre les valeurs.

A+
 

Pièces jointes

  • Fichier_test_Nico(1).xlsm
    25.3 KB · Affichages: 8

Nico2Nice

XLDnaute Nouveau
Bonsoir,
Copier ce code dans l'évènement Worksheet_Change de la feuille concernée : Feuil1(BASE)
Ajouter dans la liste des Copro la valeur INDIV

Ca le fait ?
Claude alias Pounet95

VB:
Option Explicit

Private Sub Worksheet_Change(ByVal Target As Range)
    'valeur dans la colonne des Nom Copro
    If Not Intersect(Columns(4), Target) Is Nothing Then
        Application.EnableEvents = False
        If Target = "INDIV" Then
            'aucune formule en colonnes
            Range(Cells(Target.Row, 5), Cells(Target.Row, 10)) = ""
        Else
            Formules_Recherche Target.Row
        End If
    End If
    Application.EnableEvents = True
End Sub

Private Sub Formules_Recherche(numlig As Long)
    'Ecrit les formules de recherche pour la ligne concernée passée en paramètre
    Range("E" & numlig).FormulaR1C1 = "=IF([@[Nom Corpro]]<>""INDIV"",IFERROR(VLOOKUP([@[Nom Corpro]],mes_copros,2,FALSE),""""),"""")"
    Range("F" & numlig).FormulaR1C1 = "=IFERROR(VLOOKUP([@[Nom Corpro]],mes_copros,3,FALSE),"""")"
    Range("G" & numlig).FormulaR1C1 = "=IFERROR(VLOOKUP([@[Nom Corpro]],mes_copros,4,FALSE),"""")"
    Range("H" & numlig).FormulaR1C1 = "=IFERROR(VLOOKUP([@[Nom Corpro]],mes_copros,5,FALSE),"""")"
    Range("I" & numlig).FormulaR1C1 = "=IFERROR(VLOOKUP([@[Nom Corpro]],mes_copros,6,FALSE),"""")"
    Range("J" & numlig).FormulaR1C1 = "=IFERROR(VLOOKUP([@[Nom Corpro]],mes_copros,7,FALSE),"""")"
End Sub


Bonsoir Claude
Un grand merci pour ta réponse 1 h après mon post !
Ca ne semble pas fonctionner mais j'ai peut être loupé un truc... quand j'appelle une valeur dans la colonne D (copro A, B ou C) VLOOKUP ne se lance pas... je regarde du côté de chez Job75 ;-)
 

Nico2Nice

XLDnaute Nouveau
Bonsoir Nico2Nice, Pounet95,

Voyez le fichier joint et ces 2 macros dans le code de la feuille "Base" :
VB:
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
[Tableau1].Columns(4).Validation.Delete 'RAZ
If UCase(Cells(ActiveCell.Row, 1)) = "COPRO" And Not Intersect(ActiveCell, [Tableau1].Columns(4)) Is Nothing _
    Then ActiveCell.Validation.Add xlValidateList, Formula1:="=" & [Tableau3].Columns(1).Address(External:=True)
End Sub

Private Sub Worksheet_Change(ByVal R As Range)
If Intersect(R, [Tableau1]) Is Nothing Then Exit Sub
Dim T As Range, i As Variant
Set R = Intersect(R.EntireRow, [Tableau1]).Rows
Set T = [Tableau3]
Application.ScreenUpdating = False
Application.EnableEvents = False 'désactive les évènements
For Each R In R 'si entrées ou effacements multiples
    If UCase(R.Cells(1)) = "COPRO" Then
        i = Application.Match(R.Cells(4), T.Columns(1), 0)
        If IsError(i) Then
            R.Cells(4).Resize(, 7) = "" 'RAZ
        Else
            R.Cells(5).Resize(, 6) = T(i, 2).Resize(, 6).Value
        End If
    End If
Next
Application.EnableEvents = True 'réactive les évènements
End Sub
La 1ère crée les listes de validation en colonne D, la 2ème entre les valeurs.

A+


Hello job75
Ca marche nickel !..... un grand merci ça fait 2 jours que je galère avec des bouts de codes et là tu me donnes la solution sur un plateau :) Je vais essayer de passer du temps dessus pour comprendre pas à pas. Bonne soirée
 

Pounet95

XLDnaute Occasionnel
Bonjour,
Effectivement quelque chose a dû être loupé.
Ca fonctionne très bien chez moi.
Est-ce que la valeur INDIV a bien été ajoutée , manuellement contrairement à Job75 ?
Est-ce que la macro n'a pas été interrompue avant la fin empêchant ainsi la réaction des évènements de la feuille ?
Le principal est que le problème soit résolu.
Bonne journée à toutes et tous
Claude alias Pounet95
 

Nico2Nice

XLDnaute Nouveau
Bonsoir Nico2Nice, Pounet95,

Voyez le fichier joint et ces 2 macros dans le code de la feuille "Base" :
VB:
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
[Tableau1].Columns(4).Validation.Delete 'RAZ
If UCase(Cells(ActiveCell.Row, 1)) = "COPRO" And Not Intersect(ActiveCell, [Tableau1].Columns(4)) Is Nothing _
    Then ActiveCell.Validation.Add xlValidateList, Formula1:="=" & [Tableau3].Columns(1).Address(External:=True)
End Sub

Private Sub Worksheet_Change(ByVal R As Range)
If Intersect(R, [Tableau1]) Is Nothing Then Exit Sub
Dim T As Range, i As Variant
Set R = Intersect(R.EntireRow, [Tableau1]).Rows
Set T = [Tableau3]
Application.ScreenUpdating = False
Application.EnableEvents = False 'désactive les évènements
For Each R In R 'si entrées ou effacements multiples
    If UCase(R.Cells(1)) = "COPRO" Then
        i = Application.Match(R.Cells(4), T.Columns(1), 0)
        If IsError(i) Then
            R.Cells(4).Resize(, 7) = "" 'RAZ
        Else
            R.Cells(5).Resize(, 6) = T(i, 2).Resize(, 6).Value
        End If
    End If
Next
Application.EnableEvents = True 'réactive les évènements
End Sub
La 1ère crée les listes de validation en colonne D, la 2ème entre les valeurs.

A+


Bonjour job75,
Je suis en train de transposer ton code sur mon fichier d'origine.
Dans feuille "BASE" j'avais déjà un événement "Private Sub Worksheet_Change(ByVal Target As Range)" (ci-dessous) qui me gérait la casse de certaines colonnes.
Est-ce que tu peux m'aider à comprendre comment faire cohabiter les deux ?
Bien à toi

Private Sub Worksheet_Change(ByVal Target As Range)

Dim nMnP As Range, nCell As Range

Application.EnableEvents = False
Application.ScreenUpdating = False

Set nMnP = Intersect(Target, Columns("D"))
If Not nMnP Is Nothing Then
For Each nCell In nMnP
nCell = Application.WorksheetFunction.Proper(nCell)
Next nCell
End If

Set nMnP = Intersect(Target, Columns("E"))
If Not nMnP Is Nothing Then
For Each nCell In nMnP
nCell = UCase(nCell)
Next nCell
End If

Set nMnP = Intersect(Target, Columns("AD"))
If Not nMnP Is Nothing Then
For Each nCell In nMnP
nCell = UCase(nCell)
Next nCell
End If


Application.EnableEvents = True

End Sub
 

job75

XLDnaute Barbatruc
Bonsoir Nico2Nice, le forum,

Il suffit de compléter la macro du post #3 pour mettre les majuscules en colonnes D E AD.

Mais il faudrait voir votre fichier car pour la colonne AD (en dehors) ça n'a pas grand sens.

Et la colonne E ne contient pas des textes mais des nombres.

A+
 

Nico2Nice

XLDnaute Nouveau
Bonsoir Nico2Nice, le forum,

Il suffit de compléter la macro du post #3 pour mettre les majuscules en colonnes D E AD.

Mais il faudrait voir votre fichier car pour la colonne AD (en dehors) ça n'a pas grand sens.

Et la colonne E ne contient pas des textes mais des nombres.

A+

Mon fichier origine contient plus de colonnes que celui que j'ai posté ;-)
J'ai intégré, suivant vos conseils, (ci-dessous pour mémoire) et ça fonctionne parfaitement !
Encore merci pour votre précieuse aide.

Option Explicit

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
[Tableau1].Columns(26).Validation.Delete 'RAZ
If UCase(Cells(ActiveCell.Row, 3)) = "COPRO" And Not Intersect(ActiveCell, [Tableau1].Columns(26)) Is Nothing _
Then ActiveCell.Validation.Add xlValidateList, Formula1:="=" & [Tableau3].Columns(1).Address(External:=True)

Dim nMnP As Range, nCell As Range

Application.EnableEvents = False
Application.ScreenUpdating = False

'passage des prénoms en noms propre et des noms et villes en majuscules
Set nMnP = Intersect(Target, Columns("E"))
If Not nMnP Is Nothing Then
For Each nCell In nMnP
nCell = Application.WorksheetFunction.Proper(nCell)
Next nCell
End If

Set nMnP = Intersect(Target, Columns("F"))
If Not nMnP Is Nothing Then
For Each nCell In nMnP
nCell = UCase(nCell)
Next nCell
End If

Set nMnP = Intersect(Target, Columns("AF"))
If Not nMnP Is Nothing Then
For Each nCell In nMnP
nCell = UCase(nCell)
Next nCell
End If


Application.EnableEvents = True
 

Nico2Nice

XLDnaute Nouveau
Bonsoir Job75
Désolé de ma réponse tardive, je prends connaissance de votre mail que ce jour.
En PJ mon fichier version "allégé" sans données confidentielles, effectivement s'il existe un moyen de simplifier certains codes, ça m’intéresse.
Dans sa version normale, avec toutes les données il fait un peu plus de 800 lignes et lors de filtres et de tris, effectivement, il a tendance à mouliner un peu !
Bien à vous
 

Pièces jointes

  • Fichier_test_NicoV2.xlsm
    147.1 KB · Affichages: 3

job75

XLDnaute Barbatruc
Bonsoir Nico2Nice,

Pour les noms propres et les majuscules il suffit d'ajouter ce code dans la Worksheet_Change :
VB:
    '---noms propres et majuscules---
    R.Cells(5) = Application.Proper(R.Cells(5))
    R.Cells(6) = UCase(R.Cells(6))
    R.Cells(8) = Application.Proper(R.Cells(8))
    R.Cells(9) = UCase(R.Cells(9))
Fichier (2).

A+
 

Pièces jointes

  • Fichier_test_Nico(2).xlsm
    152.9 KB · Affichages: 6

Discussions similaires

Réponses
3
Affichages
1 K

Statistiques des forums

Discussions
311 736
Messages
2 082 026
Membres
101 876
dernier inscrit
JULIEN21370