仅使用 "Y" 列中的值复制到新闻表

Question

我有这个工作代码，它从 "sheet1" C 列获取值，将其设置为 sheet 名称并创建一个新作品sheet 并复制 "testscript" sheet.

我的问题是我只需要复制具有 "Y" 的列值。

这是我的代码：

Dim rcell As Range
Dim Background As Worksheet
Set Background = ActiveSheet

For Each rcell In Range("C2:C500")
   If rcell.Value <> "" Then
        For rep = 1 To (Worksheets.Count)
           If LCase(Sheets(rep).Name) = LCase(rcell) Then
              MsgBox "This sheet already exists!"
              Exit Sub
           End If
        Next
        Sheets("TestScript").Copy After:=Sheets(Worksheets.Count)
        Sheets(Sheets.Count).Name = rcell.Value
   End If
Next rcell

Answer 1

Dim rcell As Range
Dim Background As Worksheet
Set Background = ActiveSheet

For Each rcell In Range("C2:C500")
   'if rcell has value and same row column J is equal to "Y"
   If rcell.Value <> "" And Sheets("Sheet1").Cells(rcell.Row, 10).Value = "Y" Then
        For rep = 1 To (Worksheets.Count)
           If LCase(Sheets(rep).Name) = LCase(rcell) Then
              MsgBox "This sheet already exists!"
              Exit Sub
           End If
        Next
        Sheets("TestScript").Copy After:=Sheets(Worksheets.Count)
        Sheets(Sheets.Count).Name = rcell.Value
   End If
Next rcell

Answer 2

我会按如下方式进行

Option Explicit

Sub main()
    Dim rcell As Range

    With Sheets("Sheet1") ' reference your "source" sheet for subsequent range explicit qualification
        For Each rcell In .Range("C2:C500").SpecialCells(xlCellTypeConstants) ' loop through wanted range not empty cells with "constant" (i.e. not formulas) values
           If UCase(.Cells(rcell.Row, 10)).Value = "Y" Then ' check current cell row column J value
                If Not IsSheetThere(rcell.Value) Then 'check there's no sheet named after current cell value
                    Sheets("TestScript").Copy After:=Sheets(Sheets.Count)
                    Sheets(Sheets.Count).Name = rcell.Value
                End If
           End If
        Next
    End With
End Sub

Function IsSheetThere(shtName As String) As Boolean
    On Error Resume Next 'avoid any error at following line to stop the routine
    IsSheetThere = Worksheets(shtName).Name = shtName 'try getting a sheet with the passed name. this will throw an error if no sheet is found with that name 
End Function

仅使用 "Y" 列中的值复制到新闻表

Copying to newsheet only with values from column with "Y"

vba

excel

excel-2016