复制某个工作表，并按用某列单元格的值命名

KESHI0

现需要以“合作合同-”为模板复制工作表，工作表名称为z列的文本

工作表Z列：
                  

复制后的工作表
         

改编“CSDN博主「MISS  ZHENG」”的代码如下：


Sub CopyByContent()

Dim num, name, sheet_name_source_table_name, sheet_name_source_table_colum, copy_source_table

copy_source_table_name = "合作合同-"
sheet_name_source_table_name = "合作合同-"
sheet_name_source_table_colum = "Z"
num = Sheets(sheet_name_source_table_name).UsedRange.Rows.Count '获取某个表格使用的函数
For i = 1 To num
    Sheets(copy_source_table_name).Copy After:=Sheets("合作合同-")

   name = Sheets(sheet_name_source_table_name).Cells(i, sheet_name_source_table_colum).value
    ActiveSheet.name = name
Next
End Sub



但是运行后出错：
         

请高手看看如何解决？另外，运行后会多出一个“合作合同- (2)”的工作表，如何才能不出现这个而只有“甲乙丙丁...”这几个工作表呢？

lq-1600

先删除这里！

wxxydl

Sub CopyByContent()
    Dim num, name, sheet_name_source_table_name, sheet_name_source_table_colum, copy_source_table
    copy_source_table_name = "合作合同-"
    sheet_name_source_table_name = "合作合同-"
    sheet_name_source_table_colum = "Z"
    num = Sheets(sheet_name_source_table_name).Range(sheet_name_source_table_colum & "1").End(xlDown).Row
    For i = 1 To num
        Sheets(copy_source_table_name).Copy After:=Sheets("合作合同-")
        'name = Sheets(sheet_name_source_table_name).Cells(Z1).value
        name = Sheets(sheet_name_source_table_name).Cells(i, sheet_name_source_table_colum).value
        ActiveSheet.name = name
    Next
End Sub
把红色这句改了  就可以了

zxskyqq

Sub CreateSheet()  Dim x As Range  For Each x In Range("Z1:Z200")   If x.Value <> "" Then    Sheets.Add After:=Sheets(Sheets.Count)    ActiveSheet.name = x.Value   End If  Next End Sub

zxskyqq

Sub CreateSheet()
Dim x As Range
For Each x In Range("Z1:Z200")
  If x.Value <> "" Then
   Sheets.Add After:=Sheets(Sheets.Count)
   ActiveSheet.name = x.Value
  End If
Next
End Sub

lq-1600

Sub CopyByContent()

Dim num, name, sheet_name_source_table_name, sheet_name_source_table_colum, copy_source_table

copy_source_table_name = "合作合同-"
sheet_name_source_table_name = "合作合同-"
sheet_name_source_table_colum = "Z"
num = Sheets(sheet_name_source_table_name).UsedRange.Rows.Count '获取某个表格使用的函数

For i = 1 To num
    If Sheets(sheet_name_source_table_name).Range(sheet_name_source_table_colum & i).Value = "" Then
        Exit For
    End If
    Sheets(copy_source_table_name).Copy After:=Sheets("合作合同-")

'   name = Sheets(sheet_name_source_table_name).Cells(Z1).value
   name = Sheets(sheet_name_source_table_name).Cells(i, sheet_name_source_table_colum).Value
    ActiveSheet.name = name

Next
End Sub
'————————————————
改成这样虽然能用，但是在新建工作表时没有考虑名称相同问题。
你可以参考这个网页，看看能否自己修改一下。
https://club.excelhome.net/forum ... amp;_dsign=731f86a1

KESHI0

lq-1600 发表于 2023-2-26 22:14
先删除这里！

谢谢啦，我试试！

KESHI0

wxxydl 发表于 2023-2-26 22:40
Sub CopyByContent()
    Dim num, name, sheet_name_source_table_name, sheet_name_source_table_colum, ...

完美，谢谢啦！

KESHI0

wxxydl 发表于 2023-2-26 22:40
Sub CopyByContent()
    Dim num, name, sheet_name_source_table_name, sheet_name_source_table_colum, ...

完美！谢谢！

KESHI0

zxskyqq 发表于 2023-2-26 22:45
Sub CreateSheet()
Dim x As Range
For Each x In Range("Z1:Z200")

真是简洁！改动了些地方，这样更符合我的需求：
Sub 各厂合同()
Dim x As Range
For Each x In Sheets("合作合同-").Range("Z1:Z50")
  If x.value <> "" Then
   Sheets("合作合同-").Copy After:=Sheets("合作合同-")
   ActiveSheet.name = x.value
  End If
Next
End Sub