­ã´£³¡ªL

Private Sub CommandButton1_Click()
Dim BK As Workbook, F$, T$, xB As Workbook, xS As Worksheet
Dim xD, Arr(1 To 7, 1 To 49), Brr, R&, V, xR As Range
Set BK = ThisWorkbook
Set xD = CreateObject("Scripting.Dictionary")
Application.ScreenUpdating = False
Do
  If F = "" Then F = Dir(BK.Path & "\*.xls") Else F = Dir()
  If F = "" Then Exit Do
  If Not F Like "¤µ¤éÁ`ªí(§¡­È±Æ§Ç)-*_*-(####-##-##).xls" Then GoTo 101
  T = Left(Right(F, 16), 12)
  Brr = xD(T)
  If Not IsArray(Brr) Then xD(T) = Arr:    Brr = Arr
  '-----------------------------------------------
  Set xB = Workbooks.Open(BK.Path & "\" & F, ReadOnly:=True): Set xS = xB.Sheets(1)
  R = xS.[A65536].End(xlUp).Row - 8
  If R < 10 Then xB.Close 0: GoTo 101
  'If R < 2 Then xB.Close 0: GoTo 101  '·Ó¼ÒÀÀÀ³¸Ó¥Î³o¤@¦æ
  For Each xR In xS.Cells(R, 2).Resize(1, 49)
      V = InStr("---8--37-38-4--45-39-40-", "-" & xR.Interior.ColorIndex & "-") / 3
      If Val(xR) > 0 And V > 0 Then Brr(V, xR) = Brr(V, xR) + 1
  Next
  xD(T) = Brr: xB.Close 0
101: Loop
'----------------------------------------------------
If xD.Count = 0 Then Exit Sub
Application.DisplayAlerts = False
For Each V In xD.keys
    F = "¤µ¤éÁ`ªí(§¡­È±Æ§Ç)-" & V & "_²Î­p.xls"
    BK.Sheets("Sample").Copy
    With ActiveWorkbook
         .Sheets(1).[B2].Resize(7, 49).Value = xD(V & "")
         .SaveAs Filename:=BK.Path & "\" & F, CreateBackup:=False
         .Close 0
    End With
Next
End Sub

»P¼ÒÀÀµ²ªG¤£¦P, ¶È¥H "Àx¦s®æ©³¦â" ¤Î "¼Æ¦r" ¬°§P§O,
¤µ¤éÁ`ªí(§¡­È±Æ§Ç).rar (71.11 KB)

¤U¸ü¦¸¼Æ: 3

2019-5-4 17:38

­ã´£³¡ªL

¦^´_ 18# Airman


²Ä2¬q§ï¬°:
If xD.Count = 0 Then Exit Sub
Application.DisplayAlerts = False
For Each V In xD.keys
    F = "¤µ¤éÁ`ªí(§¡­È±Æ§Ç)-" & V & "_²Î­p.xls"
    BK.Sheets("Sample").Copy
    With ActiveWorkbook
         .Sheets(1).[B2].Resize(7, 49).Value = xD(V & "")
         d$ = Format(Mid(V, 2, 10), "yyyy/m/d")
         Set xR = Nothing
         Set xR = BK.Sheets("DATA").[A:A].Find(d, Lookat:=xlPart)
         If Not xR Is Nothing Then
            For i = 4 To 9
               .Sheets(1).Cells(1, xR(1, i) + 1).Interior.ColorIndex = 6
            Next i
            Sheets(1).Cells(1, xR(1, 10) + 1).Interior.ColorIndex = 43
         End If
         .SaveAs Filename:=BK.Path & "\" & F, CreateBackup:=False
         .Close 0
    End With
Next

=============

­ã´£³¡ªL

¦^´_ 30# Scott090


SortFields §Ú³o¬OµLªk°õ¦æªº(2000ª©)