Sub test()lLastRow = Cells(Rows.Count, 1).End(xlUp).Row
k = 0
Set a = Workbooks("Пример.xlsm").Sheets("Лист3")
For i = 2 To lLastRow
k = Cells(i, 3)
If Len(Dir(Workbooks("Пример.xlsm").Path & "\" & k & ".xlsx")) > 0 Then
Workbooks.Open Filename:=Workbooks("Пример.xlsm").Path & "\" & k & ".xlsx"
Set b = ActiveWorkbook.Sheets("Лист1")
lLastRowb = b.Cells(Rows.Count, 1).End(xlUp).Row
For q = 2 To lLastRowb + 1
If b.Cells(q, 1) = "" Then
b.Cells(q, 1) = b.Cells(q - 1, 1) + 1
Exit For
End If
Next q
b.Cells(q, 2) = a.Cells(i, 2)
b.Cells(q, 3) = a.Cells(i, 3)
b.Cells(q, 3) = a.Cells(i, 4) ' =============== изменено
b.Cells(q, 3) = a.Cells(i, 5) ' =============== изменено
b.Cells(q, 3) = a.Cells(i, 6) ' =============== изменено
ActiveWorkbook.Close True
Else
Workbooks.Add
ActiveWorkbook.SaveAs Filename:=Workbooks("Пример.xlsm").Path & "\" & k & ".xlsx"
Set b = ActiveWorkbook.Sheets("Лист1")
For q = 1 To 6 ' =============== изменено
b.Cells(1, q) = a.Cells(1, q)
If q = 1 Then
b.Cells(2, q) = 1
Else
b.Cells(2, q) = a.Cells(i, q)
End If
Next q
ActiveWorkbook.Close True
End If
Next i
End Sub

Sub nb() 
Application.ScreenUpdating = False 
Set tb = ThisWorkbook.Sheets(1) 
myPath = ThisWorkbook.Path 
For i = 2 To tb.Cells(Rows.Count, 2).End(xlUp).Row 
Set newwb = Workbooks.Add 
Set ns = newwb.Sheets(1) 
arrrng = tb.Range(tb.Cells(i, 1), tb.Cells(i, 20)) 
ns.Range("A1:T1") = arrrng 
newwb.SaveAs (myPath & "\" & tb.Cells(i, 3) & ".xlsx") 
newwb.Close False 
Next 
End Sub