Como posso adicionar a lista suspensa após inserir uma nova linha no VBA

Estou tentando inserir uma lista suspensa com dois itens depois de adicionar uma nova linha. Este código abaixo não está funcionando corretamente.

     Dim varUserInput As Variant
     varUserInput = InputBox("Enter Row Number where you want to add a row:", 
    "What Row?")
    If varUserInput = "" Then Exit Sub
    RowNum = varUserInput
    Rows(RowNum + 1).Insert Shift:=xlDown
    With Sheet1.RowNum.listBox1
     .AddItem "Paris"
     .AddItem "New York"
    End With

Tente o seguinte:

Sub Macro1()

RowNum = InputBox("Enter Row Number where you want to add a row:", "What Row?")
If RowNum = "" Then Exit Sub

Range("A1").Offset(RowNum, 0).Select
Selection.Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove

With Selection.Validation
    .Delete
    .Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Operator:= _
    xlBetween, Formula1:="London,Sydney"
    .IgnoreBlank = True
    .InCellDropdown = True
    .InputTitle = ""
    .ErrorTitle = ""
    .InputMessage = ""
    .ErrorMessage = ""
    .ShowInput = True
    .ShowError = True
End With
End Sub

Nota: gravei a maior parte disso usando a ferramenta Gravar macro na guia Desenvolvedor e, em seguida, editei para usar partes do seu código. É um método útil quando você não tem certeza do código exato necessário para inserir algo, como esta lista suspensa de validação.

Editar: para adicionar duas listas ao mesmo tempo:

Sub Macro1()
'ask user for row to insert data
RowNum = InputBox("Enter Row Number where you want to add a row:", "What Row?")
If RowNum = "" Then Exit Sub

'insert dropdowns in column A
Range("A1").Offset(RowNum, 0).Select
Selection.Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove

With Selection.Validation
    .Delete
    .Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Operator:= _
    xlBetween, Formula1:="London,Sydney"
    .IgnoreBlank = True
    .InCellDropdown = True
    .InputTitle = ""
    .ErrorTitle = ""
    .InputMessage = ""
    .ErrorMessage = ""
    .ShowInput = True
    .ShowError = True
End With

'inset second drop down in column E
Range("E1").Offset(RowNum, 0).Select '<-- change reference to E
'Selection.Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove '<-- line removed as don't need to insert twice

With Selection.Validation
    .Delete
    .Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Operator:= _
    xlBetween, Formula1:="New York,Jakarta"
    .IgnoreBlank = True
    .InCellDropdown = True
    .InputTitle = ""
    .ErrorTitle = ""
    .InputMessage = ""
    .ErrorMessage = ""
    .ShowInput = True
    .ShowError = True
End With

End Sub

e com muitas listas idênticas:

Sub Macro1()
Dim RowNum As Integer
Dim Lists As Integer

'ask user for row to insert data
RowNum = InputBox("Enter Row Number where you want to add a row:", "What Row?")

'insert row
Range("A1").Offset(RowNum, 0).Select
Selection.Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove

'ask how many drop down lists to make
Lists = InputBox("Enter number of drop down lists to make in this row:", "Number?")

i = 0

Do While i < Lists And i < 1000
    With Selection.Validation
        .Delete
        .Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Operator:= _
        xlBetween, Formula1:="Hong Kong,Rome,Wellington,Cairo"
        .IgnoreBlank = True
        .InCellDropdown = True
        .InputTitle = ""
        .ErrorTitle = ""
        .InputMessage = ""
        .ErrorMessage = ""
        .ShowInput = True
        .ShowError = True
    End With

    'move across one cell
    ActiveCell.Offset(0, 1).Range("A1").Select

    i = i + 1
Loop


End Sub