提取特定行复制到多个工作表

lfray_ly

求助各位大神，有如下的工作表，F列是任务状态，G列是状态更新日期。
我想要把这些已经完成的任务（F列里有“Completed”）根据月份拆分到不同的工作表，分别按月份命名: Jan, Feb...


工作表需要生成在同一个工作簿里。
谢谢！

Task.zip (13.42 KB, 下载次数: 6)

2020-3-16 21:19 上传

点击文件名下载附件
例子

3190496160

Sub test()
Set d = CreateObject("scripting.dictionary")
Application.DisplayAlerts = False
For Each sh In Sheets
    If sh.Index > 1 Then sh.Delete
Next sh
Application.DisplayAlerts = True
ar = Sheet1.[a1].CurrentRegion
Set Rng = Sheet1.Rows(1)
ReDim br(1 To UBound(ar), 1 To UBound(ar, 2) + 1)
For i = 2 To UBound(ar)
    If Trim(ar(i, 6)) <> "" Then
        If InStr(ar(i, 6), Chr(10)) > 0 Then
            rr = Split(ar(i, 6), Chr(10))
            mm = Split(ar(i, 7), Chr(10))
            For s = 0 To UBound(rr)
                If InStr(rr(s), "Completed") > 0 Then
                    n = n + 1
                    br(n, 1) = n
                    For j = 2 To 5
                        br(n, j) = ar(i, j)
                    Next j
                    br(n, 6) = rr(s)
                    br(n, 7) = mm(s)
                    br(n, 8) = Format(Split(mm(s), " ")(0), "m")
                    d(Trim(br(n, 8))) = ""
                End If
            Next s
        ElseIf InStr(ar(i, 6), Chr(10)) = 0 Then
            n = n + 1
            br(n, 1) = n
            For j = 2 To 5
                br(n, j) = ar(i, j)
            Next j
            br(n, 6) = ar(i, 6)
            br(n, 7) = ar(i, 7)
           br(n, 8) = Format(Split(ar(i, 7), " ")(0), "m")
           d(Trim(br(n, 8))) = ""
        End If
    End If
Next i
For Each k In d.keys
    t = 0
    ReDim cr(1 To n, 1 To UBound(ar, 2))
    For i = 1 To n
        If Trim(br(i, 8)) = k Then
            t = t + 1
            cr(t, 1) = t
            For j = 2 To UBound(br, 2) - 1
                cr(t, j) = br(i, j)
            Next j
            cr(t, 2) = Replace(cr(t, 2), Chr(10), "")
        End If
    Next i
    Set sht = Worksheets.Add(after:=Sheets(Sheets.Count))
    sht.Name = k & "月"
    Rng.Copy sht.[a1]
    sht.[a2].Resize(t, UBound(cr, 2)) = cr
Next k
End Sub

3190496160

Task.rar (27.68 KB, 下载次数: 8)

2020-3-16 22:19 上传

点击文件名下载附件

lfray_ly

3190496160 发表于 2020-3-16 22:18
Sub test()
Set d = CreateObject("scripting.dictionary")
Application.DisplayAlerts = False

非常感谢，考虑得很周全，包括月份是否前面有0都考虑了。太感激了！