Question

我有这个工作代码，它从“sheet1”列C获取值，将其设置为工作表名称并制作一个新工作表并复制“testscript”工作表。

我的问题是我只需复制具有“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”列中的值复制到新闻表

2 个答案: