Fusion de cellules

Bonjour,

je découvre votre forum et j'apprends plein de chose
Super et merci à tous ceux qui interviennent !
Je coince sur un code que j'ai trouvé et arrangé pour mon application :
je souhaite, sur ma page de résultat, fusionner les cellules (b :d) pour rendre mon fichier plus exploitable .

le code :

Sub Importer()
Worksheets("FP").Range("A7:G300").ClearContents
Dim objShell As Object, objFolder As Object
Dim Chemin As String, fichier As String

Set objShell = CreateObject("Shell.Application")
Set objFolder = objShell.BrowseForFolder(&H0&, "Choisir un répertoire", &H1&)

If objFolder Is Nothing Then
MsgBox "Abandon opérateur", vbCritical, "Annulation"
Else

Chemin = objFolder.ParentFolder.ParseName(objFolder.Title).Path & "\"

fichier = Dir(Chemin & "*.xls")
Do While Len(fichier) > 0
If fichier <> ThisWorkbook.Name Then
ThisWorkbook.Names.Add "Plage", _
RefersTo:="='" & Chemin & "[" & fichier & "]FdP'!$C$2"
With Sheets("FdP")
.[A1].Copy
' lire et ecrire le nom du fichier
Sheets("FP").Range("A" & Rows.Count).End(xlUp).Offset(1, 0) = fichier
' lire et ecrire la cellule $C$2
Sheets("FP").Range("A" & Rows.Count).End(xlUp).Offset(0, 1).PasteSpecial xlPasteValues

End With
End If
' lire et ecrire la cellule $O$1
If fichier <> ThisWorkbook.Name Then
ThisWorkbook.Names.Add "Plage", _
RefersTo:="='" & Chemin & "[" & fichier & "]FdP'!$O$1"
With Sheets("FdP")

Sheets("FP").Range("A" & Rows.Count).End(xlUp).Offset(0, 4).PasteSpecial xlPasteValues
End With
End If
' lire et ecrire la cellule $O$2
If fichier <> ThisWorkbook.Name Then

ThisWorkbook.Names.Add "Plage", _
RefersTo:="='" & Chemin & "[" & fichier & "]FdP'!$O$2"
With Sheets("FdP")
Sheets("FP").Range("A" & Rows.Count).End(xlUp).Offset(0, 5).PasteSpecial xlPasteValues
End With
End If
' lire et ecrire la cellule $Q$2
If fichier <> ThisWorkbook.Name Then
ThisWorkbook.Names.Add "Plage", _
RefersTo:="='" & Chemin & "[" & fichier & "]FdP'!$Q$2"
With Sheets("FdP")
Sheets("FP").Range("A" & Rows.Count).End(xlUp).Offset(0, 6).PasteSpecial xlPasteValues
End With
End If

fichier = Dir()
Loop
End If
End Sub