[已解决]求助，如何只复制SHEET1，SHEET2，3不复制？

ytsm001 · 发表于 2010-1-15 10:34

请老师们帮忙修改一下附件中代码最后部分，实现只复制SHEET1，其它工作表不复制，先谢谢了！

CPdW1doP.rar (10.88 KB, 下载次数: 2)

amulee · 发表于 2010-1-15 11:03

这个最佳答案由 amulee 给出，感谢 amulee 的回答。

单击隐藏图章

Private Sub CommandButton1_Click()
    Dim c As String
    Dim NewBook As Workbook
    Dim NewSheet As Worksheet
    Dim OldBook As Workbook
    Set OldBook = ThisWorkbook
    imonth = Range("R12").Value
    imonth1 = Range("R11").Value
    imonth2 = Range("R13").Value
    '新建工作簿
    Set NewBook = Workbooks.Add(xlWBATWorksheet)
    Set NewSheet = NewBook.Sheets(1)
    NewSheet.Name = "Amulee"
    OldBook.Sheets(Array("Sheet1", "Sheet2")).Copy Before:=NewSheet
    Application.DisplayAlerts = False
    NewSheet.Delete
    Application.DisplayAlerts = True
    If Dir("D:\" & (imonth1) & "年" & imonth & "月", vbDirectory) = "" Then
        MkDir ("D:\" & (imonth1) & "年" & imonth & "月")
    End If
    If Dir("D:\" & (imonth1) & "年" & imonth & "月" & "\" & imonth & "月" & (imonth2) & "日", vbDirectory) = "" Then
        MkDir "D:\" & (imonth1) & "年" & imonth & "月" & "\" & imonth & "月" & (imonth2) & "日"
    End If
    If Dir("D:\" & (imonth1) & "年" & imonth & "月" & "\" & imonth & "月" & (imonth2) & "日" & "\" & Range("k3") & ".xls") = "" Then
        NewBook.SaveCopyAs Filename:=("D:\" & (imonth1) & "年" & imonth & "月" & "\" & (imonth & "月" & (imonth2) & "日") & "\" & Range("k3") & ".xls")
        Else
        t = MsgBox("是否覆盖？", vbYesNo)
        If t = vbYes Then
        NewBook.SaveCopyAs Filename:=("D:\" & (imonth1) & "年" & imonth & "月" & "\" & (imonth & "月" & (imonth2) & "日") & "\" & Range("k3") & ".xls")
             MsgBox "文件已另存到共享区"
        End If
    End If
    NewBook.Close False
End Sub

ytsm001 · 发表于 2010-1-15 12:57

多谢老师的回复，现在测试有点问题，提示下标越界，后来发现原来我的原始文件中只有一个SHEET1，增加SHEET2，SHEET3后，就可以运行了，再次感谢！

amulee · 发表于 2010-1-15 15:08

帮你加了个防错的。

Private Sub CommandButton1_Click()

    on error resume next
    Dim c As String
    Dim NewBook As Workbook
    Dim NewSheet As Worksheet
    Dim OldBook As Workbook
    Set OldBook = ThisWorkbook
    imonth = Range("R12").Value
    imonth1 = Range("R11").Value
    imonth2 = Range("R13").Value
    '新建工作簿
    Set NewBook = Workbooks.Add(xlWBATWorksheet)
    Set NewSheet = NewBook.Sheets(1)
    NewSheet.Name = "Amulee"
    OldBook.Sheets(Array("Sheet1", "Sheet2")).Copy Before:=NewSheet
    Application.DisplayAlerts = False
    NewSheet.Delete
    Application.DisplayAlerts = True
    If Dir("D:\" & (imonth1) & "年" & imonth & "月", vbDirectory) = "" Then
        MkDir ("D:\" & (imonth1) & "年" & imonth & "月")
    End If
    If Dir("D:\" & (imonth1) & "年" & imonth & "月" & "\" & imonth & "月" & (imonth2) & "日", vbDirectory) = "" Then
        MkDir "D:\" & (imonth1) & "年" & imonth & "月" & "\" & imonth & "月" & (imonth2) & "日"
    End If
    If Dir("D:\" & (imonth1) & "年" & imonth & "月" & "\" & imonth & "月" & (imonth2) & "日" & "\" & Range("k3") & ".xls") = "" Then
        NewBook.SaveCopyAs Filename:=("D:\" & (imonth1) & "年" & imonth & "月" & "\" & (imonth & "月" & (imonth2) & "日") & "\" & Range("k3") & ".xls")
        Else
        t = MsgBox("是否覆盖？", vbYesNo)
        If t = vbYes Then
        NewBook.SaveCopyAs Filename:=("D:\" & (imonth1) & "年" & imonth & "月" & "\" & (imonth & "月" & (imonth2) & "日") & "\" & Range("k3") & ".xls")
             MsgBox "文件已另存到共享区"
        End If
    End If
    NewBook.Close False
End Sub

		自动登录	找回密码
密码			注册