求助一次性生成全月每天的数据且自带编号（即批量生成）

ysxhefei

求助一次性生成全月每天的出库数据且自带编号（即批量生成）

ysxhefei

凌空一羽 发表于 2018-8-3 23:47
Sub LKYY()
Dim Mp$, Mf, sht As Worksheet, br(1 To 1000, 1 To 8)
Mp = ThisWorkbook.Path & "\营养餐 ...

老师你好，我想要根据日期和摘要栏截取前两个字是“自购”这两个条件同时满足时的数据，截取摘要栏中前两个字是“自购”，这个条件应怎么写，写在哪儿？麻烦老师有空帮解答下。

凌空一羽

见附件吧………………

凌空一羽

Sub LKYY()
Dim Mp$, Mf, sht As Worksheet, br(1 To 1000, 1 To 8)
Mp = ThisWorkbook.Path & "\营养餐台账\"
Mf = Dir(Mp & "*.xls")
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Do While Mf <> ""
With Workbooks.Open(Mp & Mf, 0)
    For Each sht In .Worksheets
        If sht.Name <> "汇总" Then
            myr = sht.Range("b1000").End(3).Row
            ar = sht.Range("a5:i" & myr)
            For i = 1 To UBound(ar)
                If Len(ar(i, 7)) Then
                    n = n + 1
                    br(n, 1) = sht.[c2]
                    br(n, 2) = sht.Name
                    br(n, 3) = Split(sht.[f2], "·")(0)
                    br(n, 4) = ar(i, 7)
                    br(n, 5) = ar(i, 7)
                    br(n, 6) = ar(i, 8)
                    br(n, 7) = ar(i, 9)
                    br(n, 8) = ar(i, 2)  '日期
                End If
            Next i
        End If
    Next
    .Close 0
End With
Mf = Dir()
Loop
If Sheets.Count > 1 Then
    For i = Sheets.Count To 2 Step -1
        Sheets(i).Delete
    Next
End If
Range("a36:h1000").ClearContents
Range("a36:h36") = [{1,2,3,4,5,6,7,8}]
Range("a37").Resize(n, 8) = br
Range("a36").CurrentRegion.Sort 8, xlAscending, Header:=xlYes
ar = Range("a36").CurrentRegion
Set d = CreateObject("Scripting.Dictionary")
For i = 2 To UBound(ar)
    If Not d.exists(ar(i, 8)) Then
        Set d(ar(i, 8)) = Range("a" & i + 35 & ":g" & i + 35)
    Else
        Set d(ar(i, 8)) = Union(d(ar(i, 8)), Range("a" & i + 35 & ":g" & i + 35))
    End If
Next
For Each Key In d.keys
    Sheets.Add after:=Sheets(Sheets.Count)
    With ActiveSheet
        .Name = Key
        Sheets("模板").Range("a1:h29").Copy .[a1]
        .[d2] = "2018-9-" & Key
        .[g2] = "编号：2018-9-" & Key & "-1"
        d(Key).Copy
        .[a5].PasteSpecial (xlPasteFormulas)
    End With
Next
Sheets("模板").Activate
Range("a36:h1000").ClearContents
Set d = Nothing
Application.DisplayAlerts = True
Application.ScreenUpdating = True
MsgBox "成功生成！", 64, "提示"
End Sub

ysxhefei

谢谢老师的帮助，真是大神。