求助复制多个工作表的问题

adon.liu

表中单元格B5-B45为自动提取的本工作簿所有工作表的名称
C列通过√做出选择
求大神指教一段代码，把选择为√的工作表，复制到新的工作簿，
多谢啦，鲜花奉上！

fzxba

1. Sub test0()
   
2.   Dim ar, br() As String, i As Long, j As Long
   
3.   Dim strPath As String, t As String, s As String, sComp As String
   
4.   
   
5.   Application.ScreenUpdating = False
   
6.   Application.DisplayAlerts = False
   
7.   
   
8.   strPath = ThisWorkbook.Path & "\"
   
9.   
   
10.   s = "√"
    
11.   sComp = s
    
12.   For i = 1 To Worksheets.Count
    
13.     sComp = sComp & Worksheets(i).Name & s
    
14.   Next
    
15.   
    
16.   With Worksheets("信息")
    
17.     ar = .Range("C5", .Cells(.Rows.Count, "B").End(xlUp)).Value
    
18.     For i = 1 To UBound(ar)
    
19.       t = Trim(ar(i, 1))
    
20.       If InStr(sComp, s & t & s) Then
    
21.         If ar(i, 2) = s Then
    
22.           j = j + 1
    
23.           ReDim Preserve br(1 To j)
    
24.           br(j) = ar(i, 1)
    
25.         End If
    
26.       End If
    
27.     Next
    
28.   End With
    
29.   
    
30.   If j Then
    
31.     Worksheets(br).Copy
    
32.     With ActiveWorkbook
    
33.       .SaveAs strPath & "一个新的工作簿", 51
    
34.       .Close
    
35.     End With
    
36.   End If
    
37.   
    
38.   Application.DisplayAlerts = True
    
39.   Application.ScreenUpdating = True
    
40.   Beep
    
41. End Sub

复制代码

fzxba

示例文件.zip (31.06 KB, 下载次数: 3)

2024-3-13 16:49 上传

点击文件名下载附件

sj15627581616

cidanji

示例文件.zip (24.88 KB, 下载次数: 8)

2024-3-13 16:56 上传

点击文件名下载附件

sj15627581616

1. Sub test()
   
2.     Dim wb1 As Workbook
   
3.     Dim wb2 As Workbook
   
4.     Application.ScreenUpdating = False
   
5.     Set wb1 = ActiveWorkbook
   
6.     arr = Range("B5:C45")
   
7.     Set wb2 = Workbooks.Add
   
8.     For i = 1 To UBound(arr)
   
9.         If arr(i, 2) = "√" Then
   
10.             wb1.Sheets(arr(i, 1)).Copy After:=wb2.Sheets(1)
    
11.         End If
    
12.     Next
    
13.     Application.ScreenUpdating = True
    
14. End Sub
    

复制代码