複製的範圍和重複檢查

Question

逗人， 我想添加到下面的代碼，行，其執行以下操作：

1. 複製從結果選項卡並將其粘貼到每一個新創建的範圍片。它應該被複制到由下面的宏填充的同一列。

我認爲，我們需要的地方添加以下代碼：

Worksheets("Results").Range("A1:A65").Copy Destination:=ActiveSheet.Range("a50:a150") ??? 

還應該檢查此列重複。

你能幫忙嗎？

的初始代碼如下：

Sub YouShouldHavePostedAnAttemptFirst() 

    Dim c As Range 
    Dim CtRows, SheetCtr As Integer 
    'Try to put your data on sheet 1 then create a new sheet so that it is the 
    'second sheet in the workbook. 

    SheetCtr = 4 

    CtRows = Application.CountA(Sheets("2nd step").Range("r:r")) 

    For Each c In Range(Cells(1, 18), Cells(CtRows, 18)) 
     c.Offset(, -10).Copy Sheets(SheetCtr).Cells(Rows.Count, "a:a").End(xlUp).Offset(1, 0) 

     If c.Offset(1, 0) <> c Then 

      Sheets.Add after:=Sheets(ActiveWorkbook.Sheets.Count) 
      SheetCtr = SheetCtr + 1 

     End If 

    Next c 

End Sub 

謝謝

Answer 1

此代碼將在那裏從結果中的數據複製到現有的表，然後創建四個新表並粘貼數據好：

Sub PopulateSheets() 

    Dim wrkSht As Worksheet 
    Dim SheetCtr As Long, x As Long 

    'First go through each sheet in the workbook. 
    'If you want other sheets apart from 'Results' to be ignored just add them to the Case. 
    'e.g. Case "Results", "Sheet1" will ignore Results & Sheet1. 
    For Each wrkSht In ThisWorkbook.Worksheets 
     Select Case wrkSht.Name 
      Case "Results" 
       'Do nothing - we're copying from this sheet. 
      Case Else 
       'Copy from Results to the other worksheet. 
       With ThisWorkbook.Worksheets("Results") 
        .Range("A1:A65").Copy Destination:=wrkSht.Range("A50") 
       End With 
     End Select 
    Next wrkSht 

    'Creates 4 sheets, copies the data over and moves the sheet to the end. 
    SheetCtr = 4 
    With ThisWorkbook 
     For x = 1 To SheetCtr 
      Set wrkSht = ThisWorkbook.Worksheets.Add 
      .Worksheets("Results").Range("A1:A65").Copy Destination:=wrkSht.Range("A50") 
      wrkSht.Move After:=Sheets(.Sheets.Count) 
     Next x 
    End With 

End Sub 

如果你只是想複製的時候添加新的工作表中的數據 -
在普通模塊中添加下面的代碼。該過程引用工作表並將結果表中的數據複製到工作表並刪除所有重複項。

Public Sub CopyToNewSheet(sht As Worksheet) 

    With sht 
     ThisWorkbook.Worksheets("Results").Range("A1:A65").Copy Destination:=.Range("A50") 
     .Range("A50:A114").RemoveDuplicates Columns:=1, Header:=xlNo 
    End With 

End Sub 

在ThisWorkbook模塊中添加下面的代碼。這就驗證了要添加一個工作表，而不是一個圖表片或任何其它類型和傳遞片參照CopyToNewSheet過程：

Private Sub Workbook_NewSheet(ByVal Sh As Object) 
    If Sh.Type = xlWorksheet Then 
     CopyToNewSheet Sh 
    End If 
End Sub