VBA Copie de noms dans des cellules à fusionner

[fb62840]

Bonjour à toutes et tous,

Voilà mon souci,

Je dois collecter une liste de noms présents sur une feuille dans un classeur afin de les coller dans un autre.


J'aimerais obtenir ce résultat par macro.

La difficulté est la suivante :
Dans le fichier où les noms se trouvent, ils sont présents dans une cellule "normales"
Ensuite,
Je dois les coller dans la colonne A à compter de la ligne 37
Le premier nom sera à placer dans A37
Les cellules de A37 à A39 doivent fusionner
Puis le nom suivant sera en A40
Les cellules de A40 à A42 doivent fusionner et ainsi de suite

c'est à dire que :
On colle le premier nom dans la cellule A37
On fusionne A37, A38 et A39
donc dans la cellule vide immédiatement sous les cellules fusionnées (ici ligne 40) le nom suivant est inscrit
on fusionne cette cellule et les 2 en dessous et ainsi de suite autant qu'il y a de noms dans le fichier source.

C'est étrange sans doute mais votre aide serait vraiment la bienvenue.


Merci beaucoup pour votre aide

 

[VBAdict]

Re : VBA Copie de noms dans des cellules à fusionner

Bonsoir,

A tester, la macro renvoie les résultats dans la feuille 2 et non dans un autre classeur, ce ne sera pas grand chose à modifier.

Sub RecupNom()

Dim tab_nom() As Variant
Dim int_ligne As Integer
Dim i As Integer

int_ligne = 4

ReDim tab_nom(0)

tab_nom(0) = ""
i = 0
Sheets("Mai 2016").Select
While Cells(int_ligne, 1) <> "EFFECTIF TOTAL"
    
 If Cells(int_ligne, 1) <> "" And Cells(int_ligne, 1) <> "RESIDENCE" And Not Cells(int_ligne, 1) Like "*EQUIPE*" Then
 'MsgBox i
    If i = 0 Then
    tab_nom(0) = Cells(int_ligne, 1)
    i = i + 1
    Else
      
    ReDim Preserve tab_nom(i)
    tab_nom(i) = Cells(int_ligne, 1)
  i = i + 1
    End If

End If
int_ligne = int_ligne + 1
Wend
int_ligne = 37
Sheets("Feuil2").Select
For i = 0 To UBound(tab_nom())

    Cells(int_ligne, 1) = tab_nom(i)
    Range(Cells(int_ligne, 1), Cells(int_ligne + 2, 1)).Select
    Selection.Merge
    int_ligne = int_ligne + 3

Next i

End Sub

@+

 

[fb62840]

Re : VBA Copie de noms dans des cellules à fusionner

Merci beaucoup pour votre aide.

En effet sur une feuille du même classeur ça ne pose pas de problème par contre, j'ignore comment faire correctement la chose suivante :

Insérer la première valeur dans la cellule A38 d'une feuille d'un autre classeur
Insérer les suivantes dans la première cellule en dessous des cellules qui viennent d'être fusionnées.

J'ai tenté de le faire ainsi mais ça ne marche pas :

pour l'instant ça bloque sur la ligne contenant : Set WB_Secondaire = Workbooks("PlannCon 2016.xls")
message = "objet requis"

Sub RecupNom()

Dim tab_nom() As Variant
Dim int_ligne As Integer
Dim i As Integer
Dim Feuille_source As String
Dim Feuille_destination As String
Dim WB_Principal As Workbook
Dim WB_Secondaire

Set WB_Principal = ActiveWorkbook
Set WB_Secondaire = Workbook("PlannCon2016.xls")
Feuille_Source = Range("A1").Value & " " & Range("A2").Value
Feuille_destination = Range("B1").Value

int_ligne = 4

ReDim tab_nom(0)

tab_nom(0) = ""
i = 0
Feuille_source = Range("A1").Value & " " & Range("A2").Value
Sheets(Feuille_source).Select
While Cells(int_ligne, 1) <> "EFFECTIF TOTAL"
    
 If Cells(int_ligne, 1) <> "" And Cells(int_ligne, 1) <> "RESIDENCE" And Not Cells(int_ligne, 1) Like "*EQUIPE*" Then
 'MsgBox i
    If i = 0 Then
    tab_nom(0) = Cells(int_ligne, 1)
    i = i + 1
    Else
      
    ReDim Preserve tab_nom(i)
    tab_nom(i) = Cells(int_ligne, 1)
  i = i + 1
    End If

End If
int_ligne = int_ligne + 1
Wend
int_ligne = 37
WK_Principal.Activate
Feuille_destination.Select

For i = 0 To UBound(tab_nom())

    Cells(int_ligne, 1) = tab_nom(i)
    Range(Cells(int_ligne, 1), Cells(int_ligne + 2, 1)).Select
    Selection.Merge
    int_ligne = int_ligne + 3

Next i

End Sub

Merci beaucoup de m'aider à finaliser

 

[VBAdict]

Re : VBA Copie de noms dans des cellules à fusionner

Bonsoir,

avec ce code il faut juste que les deux workbooks soient ouverts:

Sub RecupNom()

Dim tab_nom() As Variant
Dim int_ligne As Integer
Dim i As Integer

int_ligne = 4
Workbooks("nom du classeur où se trouvent les données").Activate 'exemple workbooks("plancong")...
ReDim tab_nom(0)

tab_nom(0) = ""
i = 0
Sheets("Mai 2016").Select
While Cells(int_ligne, 1) <> "EFFECTIF TOTAL"
    
 If Cells(int_ligne, 1) <> "" And Cells(int_ligne, 1) <> "RESIDENCE" And Not Cells(int_ligne, 1) Like "*EQUIPE*" Then
 'MsgBox i
    If i = 0 Then
    tab_nom(0) = Cells(int_ligne, 1)
    i = i + 1
    Else
      
    ReDim Preserve tab_nom(i)
    tab_nom(i) = Cells(int_ligne, 1)
  i = i + 1
    End If

End If
int_ligne = int_ligne + 1
Wend
int_ligne = 38
Workbooks("nom du workbook").Activate 'exemple workbooks("Plan 2016").activate
Sheets("Nom de la feuille cible").Select 
For i = 0 To UBound(tab_nom())

    Cells(int_ligne, 1) = tab_nom(i)
    Range(Cells(int_ligne, 1), Cells(int_ligne + 2, 1)).Select
    Selection.Merge
    int_ligne = int_ligne + 3

Next i

End Sub

A tester,