按条件自动生成新工作表, 请各位高手帮忙

snqig

根据星期二 星期四 星期六 生成一个新表

根据星期一 星期三 星期五 星期天生成一个新表

蓝桥玄霜

请见代码。

snqig

snqig

Sub lqxs()
Dim d, Arr, i&, xq, Sht As Worksheet
Set d = CreateObject("Scripting.dictionary")
Application.ScreenUpdating = False
Application.DisplayAlerts = False
For Each Sht In Sheets
    If InStr(Sht.Name, "1357") Or InStr(Sht.Name, "246") Then Sht.Delete
Next
Sheets("半网").Activate
xq = Array("星期二", "星期四", "星期六")
For j = 0 To UBound(xq)
    d(xq(j)) = ""
Next

Arr = [a1].CurrentRegion
Sheets("半网").coppy after:=Sheets(Sheets.Count)
With ActiveSheet
    .Name = "半网1357"
     For i = 32 To 2 Step -1
     If d.exists(Arr(3, i)) Then
        .Column(i).Delete
    End If
Next
End With

Sheets("半网").Copy after:=Sheets(Sheets.Count)
    With ActiveSheet
.Name = "半网246"
    For i = 32 To 2 Step -1

    If Not d.exists(Arr(3, i)) Then
    .Column(i).Delete
End If
Next
End With
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub

Sub lqxs()
Dim d, Arr, i&, xq, Sht As Worksheet
Set d = CreateObject("Scripting.dictionary")
Application.ScreenUpdating = False
Application.DisplayAlerts = False
For Each Sht In Sheets
    If InStr(Sht.Name, "1357") Or InStr(Sht.Name, "246") Then Sht.Delete
Next
Sheets("半网").Activate
xq = Array("星期二", "星期四", "星期六")
For j = 0 To UBound(xq)
    d(xq(j)) = ""
Next

Arr = [a1].CurrentRegion
Sheets("半网").coppy after:=Sheets(Sheets.Count)
With ActiveSheet
    .Name = "半网1357"
     For i = 32 To 2 Step -1
     If d.exists(Arr(3, i)) Then
        .Column(i).Delete
    End If
Next
End With

Sheets("半网").Copy after:=Sheets(Sheets.Count)
    With ActiveSheet
.Name = "半网246"
    For i = 32 To 2 Step -1

    If Not d.exists(Arr(3, i)) Then
    .Column(i).Delete
End If
Next
End With
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub

QQ214189912

snqig 发表于 2018-8-6 11:51
Sub lqxs()
Dim d, Arr, i&, xq, Sht As Worksheet
Set d = CreateObject("Scripting.dictionary")

1. Sub lqxs()
   
2.     Dim d, Arr, i&, xq, Sht As Worksheet
   
3.     Set d = CreateObject("Scripting.dictionary")
   
4.     Application.ScreenUpdating = False
   
5.     Application.DisplayAlerts = False
   
6.     For Each Sht In Sheets
   
7.         If InStr(Sht.Name, "1357") Or InStr(Sht.Name, "246") Then Sht.Delete
   
8.     Next
   
9.     Sheets("半网").Activate
   
10.     xq = Array("星期二", "星期四", "星期六")
    
11.     For j = 0 To UBound(xq)
    
12.         d(xq(j)) = ""
    
13.     Next
    
14.     Arr = Sheets("半网").[a1].CurrentRegion
    
15.     Sheets("半网").Copy after:=Sheets(Sheets.Count)
    
16.     With ActiveSheet
    
17.         .Name = "半网1357"
    
18.         For i = 32 To 2 Step -1
    
19.             If d.exists(Arr(3, i)) Then
    
20.                 .Columns(i).Delete
    
21.             End If
    
22.         Next
    
23.     End With
    
24.     Sheets("半网").Copy after:=Sheets(Sheets.Count)
    
25.     With ActiveSheet
    
26.         .Name = "半网246"
    
27.         For i = 32 To 2 Step -1
    
28.             If Not d.exists(Arr(3, i)) Then
    
29.                 .Columns(i).Delete
    
30.             End If
    
31.         Next
    
32.     End With
    
33.     Application.DisplayAlerts = True
    
34.     Application.ScreenUpdating = True
    
35. End Sub
    

复制代码