Discussion :

[initial32]

Bonjour,

Je cherche un petit script VBA pour effectuer la tâche suivante :

J'ai une longue liste de données Excel qui se présente sur cette forme :
Nom, Prénom
Institution
Ville
Adresse email
Nom, Prénom
Institution
Ville
Adresse email
Nom, Prénom
Institution
Ville
Adresse email
...etc.
Une fois de temps en temps, il y a un nom de pays.

Je cherche un script qui mettrait sur la même ligne (avec une virgule en séparateur) tous les éléments jusqu'à "Adresse email". ça ferait donc
Nom, Prénom, Institution, Ville, Adresse email
Nom, Prénom, Institution, Ville, Adresse email
Nom, Prénom, Institution, Ville, Adresse email
Nom, Prénom, Institution, Ville, Adresse email

Et une fois de temps en temps, on aurait "Pays, Nom, Prénom, Institution, Ville, Adresse email" mais c'est pas grave.

Sauriez-vous comment faire ?

Merci pour votre aide !

[Invité]

Bonjour,
test ça

Code :

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

1
2
3
4
5
6
7
8
9
10
11
12
13
14
Sub Test()
Dim R As Range
Set R = Sheets("Data").UsedRange
Dim DerL As Long
For l = 1 To R.Rows.Count Step 4
    DerL = Sheets("Resultat").Cells(Cells.Rows.Count, 1).End(xlUp).Row + 1
    If R(l, 1) = "Pays" Then
         Sheets("Resultat").Range(Sheets("Resultat").Cells(DerL, 1), Sheets("Resultat").Cells(DerL, 1).Offset(0, 4)) = Application.Transpose(R.Range(R.Cells(l, 1), R(l, 1).Offset(4)))
         l = l + 1
    Else
       Sheets("Resultat").Range(Sheets("Resultat").Cells(DerL, 1), Sheets("Resultat").Cells(DerL, 1).Offset(0, 3)) = Application.Transpose(R.Range(R.Cells(l, 1), R(l, 1).Offset(3)))
    End If
Next
End Sub

[initial32]

Merci rdurupt ! J'ai testé le code mais j'obtiens une erreur d'exécution '9' : "L'indice n'appartient pas à la sélection".

Je joins un extrait de mon fichier pour que vous puissiez voir comment se présentent les données.

[Invité]

Code :

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

1
2
3
4
5
6
7
8
9
10
11
12
13
14
Sub Test()
Dim R As Range
Set R = Sheets("Data").UsedRange
Dim DerL As Long
For l = 1 To R.Rows.Count Step 4
    DerL = Sheets("Resultats").Cells(Cells.Rows.Count, 1).End(xlUp).Row + 1
        If InStr(Trim("" & R(l, 1).Offset(4)), ",") = 0 And Trim("" & R(l, 1).Offset(4)) <> "" Then
         Sheets("Resultats").Range(Sheets("Resultats").Cells(DerL, 1), Sheets("Resultats").Cells(DerL, 1).Offset(0, 4)) = Application.Transpose(R.Range(R.Cells(l, 1), R(l, 1).Offset(4)))
         l = l + 1
    Else
       Sheets("Resultats").Range(Sheets("Resultats").Cells(DerL, 1), Sheets("Resultats").Cells(DerL, 1).Offset(0, 3)) = Application.Transpose(R.Range(R.Cells(l, 1), R(l, 1).Offset(3)))
    End If
Next
End Sub

[initial32]

Ahahah, trop balèze !
Un grand MERCI ! ça marche parfaitement !

[initial32]

En utilisant ce script, je me suis aperçu qu'il mettait sur la même ligne le contenu de 4 lignes, puis il recommence.
Idéalement, je préférerais que le script mette sur la même ligne le contenu de toutes les lignes jusqu'à ce qu'il trouve une ligne avec une adresse email (ou le symbole @, ce qui revient au même). Dans ce cas, il faut commencer à écrire une nouvelle ligne dans la feuille "Resultats".
Sauriez-vous faire ça ?

[Invité]

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
33
34
35
36
37
38
39
40
Sub Test()
Dim R As Range
Set R = Sheets("Data").UsedRange
Dim DerL As Long
Dim DerC As Integer
Dim Mail As String
DerC = 1
For l = 1 To R.Rows.Count Step 4
    DerL = SerchXls(Sheets("Resultats").Range("D:D"), Sheets("Resultats").Range("D1"), Trim("" & R(l, 1).Offset(3)), True)
    If DerL <> 0 Then
            DerC = Sheets("Resultats").Cells(DerL, Columns.Count).End(xlToLeft).Column + 1
        Else
             DerL = Sheets("Resultats").Cells(Cells.Rows.Count, 1).End(xlUp).Row + 1
        End If
 
 
        If InStr(Trim("" & R(l, 1).Offset(4)), ",") = 0 And Trim("" & R(l, 1).Offset(4)) <> "" Then
 
        If DerL = 1 Then DerL = 2
        Mail = Trim("" & R(l, 1).Offset(3))
         Sheets("Resultats").Range(Sheets("Resultats").Cells(DerL, 1), Sheets("Resultats").Cells(DerL, 1).Offset(0, 4)) = Application.Transpose(R.Range(R.Cells(l, 1), R(l, 1).Offset(4)))
         l = l + 1
    Else
 
        If DerL = 1 Then DerL = 2
        Mail = Trim("" & R(l, 1).Offset(3))
       Sheets("Resultats").Range(Sheets("Resultats").Cells(DerL, DerC), Sheets("Resultats").Cells(DerL, DerC).Offset(0, 3)) = Application.Transpose(R.Range(R.Cells(l, 1), R(l, 1).Offset(3)))
    End If
Next
End Sub
Function SerchXls(Myrange As Range, MyCellule As Range, strRecherche, EntierCell As Boolean) As Long '
On Error Resume Next
Dim CellEntrier As Integer
If EntierCell = True Then CellEntrier = xlWhole Else CellEntrier = xlPart
SerchXls = 0
   SerchXls = Myrange.Cells.Find(what:=strRecherche, After:=MyCellule, LookIn:=xlFormulas, LookAt _
        :=CellEntrier, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:= _
        False, SearchFormat:=EntierCell).Row
  If SerchXls <= MyCellule.Row Then SerchXls = 0
End Function

[initial32]

Merci beaucoup !