按方案日期命名工作表并将指定列数据复制到命名表中

yamiedie

按方案日期命名工作表并将指定列数据复制到命名表中，像12月5日至8日和12月9日至10日那样,#N/A不用管，每次筛选复制太麻烦了，请各位老师帮帮我  谢谢

excel玉米

表中的方案日期是#N/A,写代码时没有示例日期。再一个，日期取二天还是取四天，12/5到12/8有四天，12/9到12/10有二天。没有规律可言

3190496160

Sub 拆分()
Application.ScreenUpdating = False
Dim ar As Variant
Dim d As Object, dc As Object
Set d = CreateObject("scripting.dictionary")
Set dc = CreateObject("scripting.dictionary")
Application.DisplayAlerts = False
For Each sht In Worksheets
    If sht.Index > 1 Then
        sht.Delete
    End If
Next sht
Application.DisplayAlerts = True
With Sheets("Sheet2")
    r = .Cells(Rows.Count, 1).End(xlUp).Row
    ar = .Range("a1:h" & r)
    Set rn = .Rows(1)
    For i = 2 To UBound(ar)
        If Not IsError(ar(i, 1)) Then
            If Trim(ar(i, 1)) <> "" Then
                If Not d.exists(Trim(ar(i, 1))) Then
                    Set d(Trim(ar(i, 1))) = .Cells(i, 1).Resize(1, 8)
                Else
                    Set d(Trim(ar(i, 1))) = Union(d(Trim(ar(i, 1))), .Cells(i, 1).Resize(1, 8))
                End If
            End If
        End If
    Next i
End With
x = d.keys
For i = 0 To UBound(x)
    Set sh = Sheets.Add(after:=Sheets(Sheets.Count))
    With ActiveSheet
        .Name = x(i)
        rn.Copy .[a1]
        d.items()(i).Copy .[a2]
        For j = 8 To 2 Step -1
            If j = 2 Or j = 4 Or j = 6 Then
                .Columns(j).Delete
            End If
        Next j
    End With
Next i
Application.ScreenUpdating = True
MsgBox "ok!"
End Sub

3190496160

3190496160

案例.rar (940.96 KB, 下载次数: 11)

2023-3-11 09:30 上传

点击文件名下载附件

yamiedie

3190496160 发表于 2023-3-11 09:30

谢谢大神   就是这个效果

yamiedie

3190496160 发表于 2023-3-11 09:30

大神能给注释下么   有些看不懂

gwjkkkkk

数组法参与一下。。。

ExcelHomeFM

1. Sub SplitTable()
   
2.     Dim splitRng As Range, thisSht As Worksheet, shtName$
   
3.     Set thisSht = Worksheets("Sheet2")
   
4.    
   
5.     With thisSht
   
6.         Set splitRng = .Cells(1, 1).CurrentRegion
   
7.          DeleteSheets .Name
   
8.         .[a1].AutoFilter
   
9. 
   
10.         Intersect(splitRng, .Columns(1)).AdvancedFilter Action:=xlFilterCopy, _
    
11.         CopyToRange:=.Cells(1, Columns.Count), Unique:=True
    
12.         
    
13.         For i = 2 To .Cells(Rows.Count, Columns.Count).End(xlUp).Row
    
14.             If Not IsError(.Cells(i, Columns.Count)) Then
    
15.                 shtName = .Cells(i, Columns.Count)
    
16.                 splitRng.AutoFilter Field:=1, Criteria1:=shtName
    
17.                 Sheets.Add After:=Worksheets(Worksheets.Count)
    
18.                 ActiveSheet.Name = shtName
    
19.                 splitRng.SpecialCells(xlCellTypeVisible).Copy [a1]
    
20.             End If
    
21.         Next
    
22.         
    
23.         .Activate
    
24.         .[a1].AutoFilter
    
25.         .Columns(Columns.Count).Clear
    
26.     End With
    
27.     Set thisSht = Nothing
    
28.     Set splitRng = Nothing
    
29. End Sub
    
30. 
    
31. Sub DeleteSheets(ByVal shtName As String)
    
32.     Dim sheet As Worksheet
    
33.     Application.DisplayAlerts = False
    
34.     For Each sheet In Worksheets
    
35.         If sheet.Name <> shtName Then sheet.Delete
    
36.     Next
    
37.     Application.DisplayAlerts = True
    
38. End Sub

复制代码

yamiedie

gwjkkkkk 发表于 2023-3-11 13:37
数组法参与一下。。。

大神，麻烦帮改下行么   按指定列复制，就按我附件中例子那样指定的列