Appending To current file VBA

[Mustoe95]

Hi all,

I have a vba set up already that works perfectly.

Shown below (Any simplifications would be brilliant)

Sub sbVBS_To_Delete_EntireRow()
Rows(1).EntireRow.Delete
ActiveSheet.Name = "Master"
'Updateby20150707
Dim Rng As Range
Dim xInterval As Integer
Dim xRows As Integer
Dim xRowsCount As Integer
Dim xNum1 As Integer
Dim xNum2 As Integer
Dim WorkRng As Range
Dim xWs As Worksheet
xTitleId = "KutoolsforExcel"
Set WorkRng = Application.Selection
Set WorkRng = Application.InputBox("Range", xTitleId, WorkRng.Address, Type:=8)
xRowsCount = WorkRng.Rows.Count
xInterval = Application.InputBox("Enter row interval. ", xTitleId, 100, Type:=1)
xRows = Application.InputBox("How many rows to insert at each interval? ", xTitleId, 1, Type:=1)
xNum1 = WorkRng.Row + xInterval
xNum2 = xRows + xInterval
Set xWs = WorkRng.Parent
For i = 1 To Int(xRowsCount / xInterval)
xWs.Range(xWs.Cells(xNum1, WorkRng.Column), xWs.Cells(xNum1 + xRows - 1, WorkRng.Column)).Select
Application.Selection.EntireRow.Insert
xNum1 = xNum1 + xNum2
Next
Sheets.Add After:=Sheets(Sheets.Count)
ActiveCell.FormulaR1C1 = "Alex"
Range("A2").Select
ActiveCell.FormulaR1C1 = "Andrew"
Range("A3").Select
ActiveCell.FormulaR1C1 = "Martin"
Range("A4").Select
ActiveCell.FormulaR1C1 = "Peter"
Range("A5").Select
ActiveCell.FormulaR1C1 = "Vince"
Range("A6").Select
ActiveCell.FormulaR1C1 = "Lee"
Range("A7").Select
ActiveCell.FormulaR1C1 = "Christine"
Range("A8").Select
ActiveCell.FormulaR1C1 = "Alison"
Range("A9").Select
ActiveCell.FormulaR1C1 = "Deb"
Range("A10").Select
ActiveCell.FormulaR1C1 = "Terri"
Range("A11").Select
ActiveSheet.Name = "Names"
mycount = 0
myrow = 0
Do
mycount = mycount + 1
oldrow = myrow + 1
Sheets("Master").Select
Do
myrow = myrow + 1
Loop Until Sheets("Master").Range("A" & myrow) = ""
Sheets.Add
ActiveSheet.Name = "Data" & mycount
Sheets("Master").Select
Rows(oldrow & ":" & myrow).Select
Selection.Copy
Sheets("Data" & mycount).Select
Range("A1").Select
ActiveSheet.Paste
Loop Until Sheets("Master").Range("A" & myrow + 1) = ""

With Sheets("Names").Range("A1:A10")
For n = 1 To 10
Sheets("Data" & n).Name = .Cells
Next n
End With
'Updateby20140612
Dim xPath As String
xPath = Application.ActiveWorkbook.Path
Application.ScreenUpdating = False
Application.DisplayAlerts = False
For Each xWs In ThisWorkbook.Sheets
xWs.Copy
Application.ActiveWorkbook.SaveAs Filename:=xPath & "" & xWs.Name & ".xlsx"
Application.ActiveWorkbook.Close False
Next
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub






But The last step creates the new workbooks, but since that process has already happened, I want to replace the last step so that it appends the data to the workbooks that have already been completed.

Is this possible?