Вы можете попробовать с этим сценарием и запустить DuplicateLine sub
Function getLastCell(pChamp As String)
Dim LastColonne As Double
Dim LastLigne As Double
Dim vCurrentCell
vCurrentCell = ActiveCell.Address
ActiveCell.SpecialCells(xlLastCell).Select
LastColonne = ActiveCell.Column
LastColonne = LastColonne
LastLigne = ActiveCell.Row
LastLigne = LastLigne
Range(vCurrentCell).Select
If pChamp = "LINE" Then
getLastCell = LastLigne
ElseIf pChamp = "COLUMN" Then
getLastCell = LastColonne
Else
getLastCell = "ERROR : Param LINE / COLUMN"
End If
End Function
Function CutLine(pLine As Variant, pSeparator As String)
Dim fields As Variant
Dim vLine As Variant
fields = Array()
i = 0
pos = 1
vLine = pLine
Do While pos <> 0
pos = InStr(vLine, pSeparator)
ReDim Preserve fields(i)
If pos <> 0 Then
fields(i) = Left(vLine, pos - 1)
vLine = Mid(vLine, pos + Len(pSeparator))
Else
fields(i) = vLine
End If
i = i + 1
Loop
CutLine = fields
End Function
Function getElement(pString As String, pSeparator As String, pId As Double)
vTab = CutLine(pString, pSeparator)
getElement = vTab(pId - 1)
'getElement = vTab(0)
End Function
Function getNbElement(pString As String, pSeparator As String)
vTab = CutLine(pString, pSeparator)
getNbElement = UBound(vTab) + 1
End Function
Function getLastElement(pString As String, pSeparator As String)
vTab = CutLine(pString, pSeparator)
getLastElement = vTab(UBound(vTab))
End Function
Function ColumnLetter(ColumnNumber As Double) As String
If ColumnNumber <= 0 Then
'negative column number
ColumnLetter = ""
ElseIf ColumnNumber > 16384 Then
'column not supported (too big) in Excel 2007
ColumnLetter = ""
ElseIf ColumnNumber > 702 Then
' triple letter columns
ColumnLetter = _
Chr((Int((ColumnNumber - 1 - 26 - 676) / 676)) Mod 676 + 65) & _
Chr((Int((ColumnNumber - 1 - 26) / 26) Mod 26) + 65) & _
Chr(((ColumnNumber - 1) Mod 26) + 65)
ElseIf ColumnNumber > 26 Then
' double letter columns
ColumnLetter = Chr(Int((ColumnNumber - 1) / 26) + 64) & _
Chr(((ColumnNumber - 1) Mod 26) + 65)
Else
' single letter columns
ColumnLetter = Chr(ColumnNumber + 64)
End If
End Function
Sub DuplicateLine()
Dim j As Double
vMaxLigne = getLastCell("LINE")
vNewLineId = vMaxLigne + 1
For i = 2 To vMaxLigne
vNbSite = Cells(i, 3)
If vNbSite <> "" Then 'Manage Null Rows
If vNbSite > 1 Then
For j = 1 To vNbSite
'Copy Original Line
Rows(i & ":" & i).Copy
'Insert Original Line in New Line
Rows(vNewLineId & ":" & vNewLineId).Insert Shift:=xlDown
vNgr = getElement(Cells(i, 2), ", ", j)
Range("B" & vNewLineId).Value = vNgr
vNewLineId = vNewLineId + 1
Next j
End If
End If
Next i
'Delete Original Line
Rows(2 & ":" & vMaxLigne).Delete Shift:=xlUp
End Sub