时间戳

首页 > 解决方案 > VBA：将命名工作表移动到新工作簿并保存

excel - VBA：将命名工作表移动到新工作簿并保存

问题描述

我发现这段代码真的很棒，但我希望有人能指导我如何移动未命名为valid、control和data的工作表。3 个命名表是我的常量，不需要移动它们。

Option Explicit

Sub MoveSheets()
Dim sPath As String
Dim sAddress As String
Dim wbCur As Workbook
Dim wsCur As Worksheet

'-- Store path of this workbook --
sPath = ThisWorkbook.Path & Application.PathSeparator

'-- Loop thru worksheets --
For Each wsCur In ThisWorkbook.Worksheets
    On Error Resume Next
    Set wbCur = Nothing
    '-- Add a new workbook --
    Set wbCur = Workbooks.Add
    On Error GoTo 0
    If wbCur Is Nothing Then
        '-- Report any error --
        MsgBox prompt:=Err.Description
    Else
        '-- Rename sheet 1 of new workbook --
        wbCur.Sheets(1).Name = wsCur.Name
        '-- Get range address of input data --
        sAddress = wsCur.UsedRange.Address
        '-- Copy & paste data --
        wsCur.UsedRange.Copy Destination:=wbCur.Sheets(1).Range(sAddress)
        '-- Save new workbook with filename = current worksheet name --
        wbCur.Close savechanges:=True, Filename:=sPath & wsCur.Name & ".xlsx"
    End If
Next wsCur
End Sub

标签： excelvba

解决方案

请测试下一个代码：

Sub MoveSheets()
 Dim sPath As String, sAddress As String, wsCur As Worksheet
 Dim arrNoMoveSh, mtchSh

 arrNoMoveSh = Split("valid,control,data", ",") 'create an array of the sheets name to not be moved
 '-- Store path of this workbook --
 sPath = ThisWorkbook.path & Application.PathSeparator

  '-- Loop through worksheets --
 For Each wsCur In ThisWorkbook.Worksheets
      mtchSh = Application.match(wsCur.Name, arrNoMoveSh, 0)
      If IsError(mtchSh) Then 'no sheet names found in the array
          wsCur.Copy 'create a new workbook for the sheet to be copied!!!
          ActiveWorkbook.Close savechanges:=True, FileName:=sPath & wsCur.Name & ".xlsx"
     End If
 Next wsCur
End Sub

推荐阅读