Excel 根据不同的应用场景，条件选择不同的工作表格另存为新的工作薄 VB该如何编写

思绪缥缈2650915

各位大神，请问Excel 根据不同的应用场景，从母版工作薄条件选择不同的工作表格另存为新的工作薄 VB该如何编写？ 跪求各位大神帮忙解答。谢谢~！

网络上查找的代码东拼西凑如下:


Sub 另存为()
Dim sh As Worksheet, m&
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Dim i As Long
    With Sheets("Sheet1")
       For i = 1 To 11  '工作薄一共有11个sheet
          If .Cells(15, Chr(i + 98)) = "√" Then    '11个单元格内容与11个一一sheet对应，根据√来判断sheet是否保存
          jj = Cells(14, Chr(i + 98)).Value      '若是改成Then  Sheets(Cells(14, Chr(i + 98)).Value).Copy，循环条件选择，最终选择好的所有Sheet全部另存为又该如何编写
         
          For Each sh In Worksheets
         
         If sh.Visible = xlSheetVisible And sh.Name = "jj" Then
        m = m + 1
        If m = 1 Then sh.Select Else sh.Select False
        End If
       Next
       ActiveWindow.SelectedSheets.Copy
      For Each sh In Worksheets
      sh.Unprotect
      With sh.UsedRange
      .Value = .Value
     End With
     Next
FileSource = Range("D10")  'sheet1 D10单元格有新的存储路径
  .SaveAs Filename:=FileSource & "\" & Range("D9").Value & ".xls", FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False
'        每次另存为名字根据Sheet1 D9单元格内容命名。另存为的工作薄最好无VBA代码
    Application.ScreenUpdating = True
              
            
            End If
     Next
End With
End Sub

3190496160

上传附件才可能帮到你的

思绪缥缈2650915

3190496160 发表于 2020-9-9 08:34
上传附件才可能帮到你的

附件已上传，麻烦大神帮忙看看，非常感谢~！

思绪缥缈2650915

附件为遇到困难的表格。

思绪缥缈2650915

Sub DDD()
   
    Dim sh As Worksheet, m&
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    Dim wksSht As Worksheet
    Dim intCount As Integer
    Dim astrArr() As String
    Dim i As Long
   
   
   
    With Sheets("Test Plan")
        For i = 1 To 11
            If .Cells(15, Chr(i + 98)) = "√" Then
               
               
               
                For Each wksSht In Worksheets
                    If VBA.InStr(i, wksSht.Name) = Cells(14, Chr(i + 98)).Value Then
                        i = i + 1
                        ReDim Preserve astrArr(1 To i)
                        astrArr(UBound(astrArr)) = wksSht.Name
                    End If
                    
                    
                    
                Next wksSht
                If intCount > 0 Then
                    
                    Worksheets(astrArr).Copy
                    ActiveWorkbook.SaveAs Filename:= _
                        ThisWorkbook.Path & "\SheetsBackup.xlsx"
                    
                End If
               
            End If
        Next
    End With
    Set wksSht = Nothing
   
   
   
End Sub