Создайте новый лист и данные для обработки

Question

У меня есть код ниже, который создаст новый лист при выборе A2, который отлично работает, но то, что я также пытаюсь сделать, это также скопировать данные в строке 2 и скопировать это через в новый лист. Наряду с этим, если я нажму на A3, чтобы создать другой рабочий лист, я хочу скопировать данные в строке 3 на этот лист и так далее.

Любые идеи?

Private Sub Worksheet_SelectionChange() 

Dim cTab As Integer 
cTab = ActiveCell.Row - 1 


    If Selection.Count = 1 Then 

     If Not Intersect(Target, Range("A2:A201")) Is Nothing Then 

      Dim WS1 As Worksheet 
      On Error Resume Next 
      Set WS1 = Worksheets(cTab & ".") 

      If WS1 Is Nothing Then 

       Application.ScreenUpdating = False 
       ActiveCell = cTab & "." 
        Sheets("Template").Visible = True 
       Sheets("Template").Select 
       Sheets("Template").Copy After:=Sheets(Worksheets.Count) 
       ActiveSheet.Name = cTab & "." 
       'Sheets("Template").Visible = False 
       Application.ScreenUpdating = True 

       Else 

       Sheets(cTab & ".").Select 

      End If 
     End If 
    End If 

End Sub 

Answer 1

Вы можете изменить свой код так, как показано ниже, который должен скопировать строки, как вы описали.

Private Sub Worksheet_SelectionChange(ByVal Target As Range) 
    Dim cTab As Integer 
    Dim BaseSht As Worksheet 
    Dim NewSht As Worksheet 

    Set BaseSht = ActiveSheet 

    cTab = ActiveCell.Row - 1 

    If Selection.Count = 1 Then 

     If Not Intersect(Target, Range("A2:A201")) Is Nothing Then 

      Dim WS1 As Worksheet 
      On Error Resume Next 
      Set WS1 = Worksheets(cTab & ".") 

      If WS1 Is Nothing Then 

       Application.ScreenUpdating = False 
       ActiveCell = cTab & "." 
       Sheets("Template").Visible = True 

       Sheets("Template").Copy After:=Sheets(Worksheets.Count) 
       ActiveSheet.Name = cTab & "." 
       Set NewSht = ActiveSheet 

       BaseSht.Select 

       'Copy row to new sheet 
       BaseSht.Range(ActiveCell.Address & ":" & BaseSht.Cells(ActiveCell.Row, Columns.Count).End(xlToLeft).Address).Copy NewSht.Range("A" & cTab + 1) 

       'Sheets("Template").Visible = False 
       Application.ScreenUpdating = True 

       Else 

       Sheets(cTab & ".").Select 

      End If 
     End If 
    End If 

End Sub