Discussion :

[Bifrons61]

Besoin d'aide, on doit compléter une feuille avec des données clients dans différentes cellules placées dans cette même feuille.

Je veux récupérer des données dans un onglet "saisie" dans les cellules (par exemple) C19, C20, C21 et D22 et les copier dans un autre onglet "clients" dans la 1ère ligne vide C19 en A1, C20 en A2, C21 en A3 et D22 en A4.

Une fois la macro partielle ci-dessus exécutée, je veux effacer le contenu des cellules C19, C20, C21 et D22 et ensuite placer le curseur dans la cellule C19

Pour un spécialiste ce ne doit pas être très compliqué, moi je nage.

Merci d'avance pour le coup de mains

[ARTURO83]

Bonjour,

Voici 2 propositions.
la première avec toujours les mêmes cellules de la feuille "saisie" exemple; C19,C20,C21,D22) à adapter selon vos besoins.

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
Option Compare Text
 
'Macro utilisable pour les cellules fixes
Sub Recup_Valeurs()
    Dim f1 As Worksheet, f2 As Worksheet
    Dim DerLig_f2 As Long, i As Long
    Dim Valeur As Variant
    Application.ScreenUpdating = False
    Set f1 = Sheets("saisie")
    Set f2 = Sheets("clients")
    DerLig_f2 = f2.Range("A" & Rows.Count).End(xlUp).Row
 
    'Récupération des valeurs sélectionnées dans la feuille "saisie"
    NbValeurs = 4 'Nombre de valeurs à recopier
    Valeurs = Array(f1.[C19], f1.[C20], f1.[C21], f1.[D22]) 'les valeurs à recopier
 
    'Recopie des valeurs dans la feuille "clients"
    f2.Cells(DerLig_f2, "A").Offset(1, 0).Resize(NbValeurs, 1) = Application.WorksheetFunction.Transpose(Valeurs)
 
    'suppression ds lignes vides
    For i = DerLig_f2 + Selection.Count - 1 To 1 Step -1
        If f2.Cells(i, "A") = "" Then f2.Rows(i).Delete
    Next i
 
    f1.Range("C19, C20, C21, D22").ClearContents 'on efface les cellules
 
    Set f1 = Nothing
    Set f2 = Nothing
End Sub

La seconde: Avec des cellules sélectionnées avec la souris (utiliser la touche CTRL pour les cellules discontinues)

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
Option Compare Text
 
'Macro utilisable pour les cellules sélectionnées avec la souris
Sub Recup_Valeurs()
    Dim f1 As Worksheet, f2 As Worksheet
    Dim DerLig_f2 As Long, i As Long
    Dim Valeur As Variant
    Application.ScreenUpdating = False
    Set f1 = Sheets("saisie")
    Set f2 = Sheets("clients")
    DerLig_f2 = f2.Range("A" & Rows.Count).End(xlUp).Row
 
    'Récupération des valeurs sélectionnées dans la feuille "saisie"
    ReDim Valeur(Selection.Count) As String
    i = 1
    For Each cell In Selection 'pour chaque valeurs
        Valeur(i) = cell.Value 'on mémorise la valeur avec un N° d'index
        cell.Value = "" 'on efface la cellule
        i = i + 1 'on passe à la valeur suivante
    Next
 
    'Recopie des valeurs dans la feuille "clients"
    f2.Cells(DerLig_f2, "A").Offset(1, 0).Resize(Selection.Count + 1, 1) = Application.WorksheetFunction.Transpose(Valeur)
 
    'suppression ds lignes vides
    For i = DerLig_f2 + Selection.Count - 1 To 1 Step -1
        If f2.Cells(i, "A") = "" Then f2.Rows(i).Delete
    Next i
 
    Set f1 = Nothing
    Set f2 = Nothing
End Sub

Cdlt

[Bifrons61]

Super, merci sauf que ...
Dans l'onglet "Clients" les données sont toutes copiées dans la colonne A comme ci-dessous


Le résultat souhaité était d'avoir les données sur une ligne différente à chaque exécution de la macro comme ci-dessous


Autre "petit" bug, si une des 4 cellules à copier est vide, la macro s'arrête et affiche une erreur d'exécution 13 (incompatibilité de type) et ce cas de cellule vide se présentera assez souvent

Merci d'avance pour l'aide

[ARTURO83]

Dans l'onglet "Clients" les données sont toutes copiées dans la colonne A comme ci-dessous

Pourtant il me semble bien que c'était ce qui été demandé initialement:

les copier dans un autre onglet "clients" dans la 1ère ligne vide C19 en A1, C20 en A2, C21 en A3 et D22 en A4

Voici avec la modif

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
Option Compare Text
 
'Macro utilisable pour les cellules fixes
Sub Recup_Valeurs()
    Dim f1 As Worksheet, f2 As Worksheet
    Dim DerLig_f2 As Long, i As Long
    Dim Valeur As Variant
    Application.ScreenUpdating = False
    Set f1 = Sheets("saisie")
    Set f2 = Sheets("clients")
    DerLig_f2 = f2.Range("A" & Rows.Count).End(xlUp).Row
 
    'Récupération des valeurs sélectionnées dans la feuille "saisie"
    NbValeurs = 4 'Nombre de valeurs à recopier
    Valeurs = Array(f1.[C19], f1.[C20], f1.[C21], f1.[D22]) 'les valeurs à recopier
 
    'Recopie des valeurs dans la feuille "clients"
    f2.Cells(DerLig_f2, "A").Offset(1, 0).Resize(, NbValeurs) = Application.WorksheetFunction.Transpose(Application.WorksheetFunction.Transpose(Valeurs))
 
    'suppression ds lignes vides
    For i = DerLig_f2 + Selection.Count - 1 To 1 Step -1
        If f2.Cells(i, "A") = "" Then f2.Rows(i).Delete
    Next i
 
    f1.Range("C19, C20, C21, D22").ClearContents 'on efface les cellules
 
    Set f1 = Nothing
    Set f2 = Nothing
End Sub

Cdlt

[Bifrons61]

Oui je me suis trompé dans le 1er post, désolé

Ça fonctionne super bien maintenant, il y a juste encore un détail si une cellule à copier est vide, la macro affiche une erreur d'exécution 13 (incompatibilité de type) et ce cas de cellule vide se présentera assez souvent

Merci déjà pour cette aide précieuse

[ARTURO83]

Voilà, pour toutes les cellules à relever, j'ajoute une "£" à chaque valeur, ainsi il n'y a jamais de valeur à vide. A la fin de l'exécution de la macro, ces "£" sont supprimées.

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
Option Compare Text
 
'Macro utilisable pour les cellules fixes
Sub Recup_Valeurs()
    Dim f1 As Worksheet, f2 As Worksheet
    Dim DerLig_f2 As Long, i As Long
    Dim Valeur As Variant
    Application.ScreenUpdating = False
    Set f1 = Sheets("saisie")
    Set f2 = Sheets("clients")
    DerLig_f2 = f2.Range("A" & Rows.Count).End(xlUp).Row
 
    'Récupération des valeurs sélectionnées dans la feuille "saisie"
    NbValeurs = 4 'Nombre de valeurs à recopier
    Valeurs = Array(f1.[C19] & "£", f1.[C20] & "£", f1.[C21] & "£", f1.[D22] & "£") 'les valeurs à recopier
 
    'Recopie des valeurs dans la feuille "clients"
    f2.Cells(DerLig_f2, "A").Offset(1, 0).Resize(, NbValeurs) = Application.WorksheetFunction.Transpose(Application.WorksheetFunction.Transpose(Valeurs))
 
    f1.Range("C19, C20, C21, D22").ClearContents 'on efface les cellules
 
    f2.Select
   'Effacement des caractères excédentaires
    Range(Cells(DerLig_f2 + 1, 1), Cells(DerLig_f2 + 1, NbValeurs)).Replace What:="£", Replacement:="", LookAt:=xlPart
    'suppression ds lignes vides
    For i = DerLig_f2 + Selection.Count - 1 To 1 Step -1
        If Cells(i, "A") = "" Then Rows(i).Delete
    Next i
 
    Set f1 = Nothing
    Set f2 = Nothing
End Sub

Cdlt

[Bifrons61]

Bravo et merci pour ton aide
ça fonctionne super bien
Belle journée
Salutations