新しいシートを作成してデータをコピーする

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