Airman

¦^´_ 10# Scott090
Scott090¤j¤j:±z¦n!
1. ÀÉ®×¥H ¤é´Á§Ç °µ¤ÀÃþ¡F »P  X-Y µLÃö ==> OK! 8#ªº¸É¥R»¡©ú~½Ð"©¿²¤"§Y¥i¡C
2. ¦P¤@¤ÀÃþ¤º¨C¤@­ÓÀɮ׳£°µ¬Û¦Pªº²Î­p³W«h¡A
     ²Î­p³W«h¡G
                       ..........                     
                ..........
²Î­p³W«h¡G¤£¹ï!

¤U¸ü (55.24 KB)

2019-5-4 14:19

¤U¸ü (63.94 KB)

2019-5-4 14:20

¤U¸ü (62.18 KB)

2019-5-4 14:20

³W«h­«ÂI¾ã²z~ÂԽаѦÒ~
²Î­p½d³ò¡G
1_Àɮפº¤u§@ªíªºCells([B65536].End(xlUp).Row) <10(§Y³Ì«á¦³¼Æ¦rªº¦C¼Æ¤p©ó²Ä10¦C)ªºÀɮײ¤¹L¤£­p¡C
2_·j´M²Î­pªº½d³ò±q²Ä2¦C(§Y²Ä¤@¦C¼ÐÃDªº¼Æ¦r¤£¦b­pºâ½d³ò)¨ìCells([B65536].End(xlUp).Row - 8, 2).Resize(1, 49)¡C

²Î­p³W«h¡G
³æ¤@­Ó(§Y¦³¼Ð¥Ü40¸¹©³¦â)¬O«ü¡JÀɮפºªº¤u§@ªí¤§
·íCells([B65536].End(xlUp).Row - 8, 2).Resize(1, 49)¦³Åã¥Ü¼Æ¦r(§Y<>"")¡A
¦ýCells([B65536].End(xlUp).Row - 9, 2).Resize(1, 49)ªº¦PÄæ¨S¦³¼Æ¦r(§Y="")
©Î
·íCells([B65536].End(xlUp).Row - 8, 2).Resize(1, 49)=²Ä2¦C®É¡A¬YÄ榳Åã¥Ü¼Æ¦r(§Y<>"")¡A

³s2­Ó(§Y¦³¼Ð¥Ü39¸¹©³¦â)¬O«ü¡JÀɮפºªº¤u§@ªí¤§
·íCells([B65536].End(xlUp).Row - 8, 2).Resize(1, 49)¦³Åã¥Ü¼Æ¦r(§Y<>"")¡A
¥BCells([B65536].End(xlUp).Row - 9, 2).Resize(1, 49)ªº¦PÄæ¤]¦³¼Æ¦r(§Y<>"")
¦ýCells([B65536].End(xlUp).Row - 10, 2).Resize(1, 49)ªº¦PÄæ¨S¦³¼Æ¦r(§Y="")
©Î
·íCells([B65536].End(xlUp).Row - 8, 2).Resize(1, 49)=²Ä3¦C®É¡A¬YÄ榳Åã¥Ü¼Æ¦r(§Y<>"")¡A
¥BCells([B65536].End(xlUp).Row - 9, 2).Resize(1, 49)ªº¦PÄæ¤]¦³¼Æ¦r(§Y<>"")

³s3­Ó(§Y¦³¼Ð¥Ü45¸¹©³¦â)¬O«ü¡JÀɮפºªº¤u§@ªí¤§
·íCells([B65536].End(xlUp).Row - 8, 2).Resize(1, 49)¦³Åã¥Ü¼Æ¦r(§Y<>"")¡A
¥BCells([B65536].End(xlUp).Row - 9, 2).Resize(1, 49)ªº¦PÄæ¤]¦³¼Æ¦r(§Y<>"")
¥BCells([B65536].End(xlUp).Row - 10, 2).Resize(1, 49)ªº¦PÄæ¤]¦³¼Æ¦r(§Y<>"")
¦ýCells([B65536].End(xlUp).Row - 11, 2).Resize(1, 49)ªº¦PÄæ¨S¦³¼Æ¦r(§Y="")
©Î
·íCells([B65536].End(xlUp).Row - 8, 2).Resize(1, 49)=²Ä4¦C®É¡A¬YÄ榳Åã¥Ü¼Æ¦r(§Y<>"")¡A
¥BCells([B65536].End(xlUp).Row - 9, 2).Resize(1, 49)ªº¦PÄæ¤]¦³¼Æ¦r(§Y<>"")
¥BCells([B65536].End(xlUp).Row - 10, 2).Resize(1, 49)ªº¦PÄæ¤]¦³¼Æ¦r(§Y<>"")

¨ä¾l³s4­Ó¡A....¡A³s6­Ó¥H¦¹Ãþ±À¡C

³s7­Ó(§Y¦³¼Ð¥Ü8¸¹©³¦â)¬O«ü¡JÀɮפºªº¤u§@ªí¤§
·íCells([B65536].End(xlUp).Row - 8, 2).Resize(1, 49)¦³Åã¥Ü¼Æ¦r(§Y<>"")¡A
¥BCells([B65536].End(xlUp).Row - 9, 2).Resize(1, 49)ªº¦PÄæ¤]¦³¼Æ¦r(§Y<>"")
¥BCells([B65536].End(xlUp).Row - 10, 2).Resize(1, 49)ªº¦PÄæ¤]¦³¼Æ¦r(§Y<>"")
¥BCells([B65536].End(xlUp).Row - 11, 2).Resize(1, 49)ªº¦PÄæ¤]¦³¼Æ¦r(§Y<>"")
¥BCells([B65536].End(xlUp).Row - 12, 2).Resize(1, 49)ªº¦PÄæ¤]¦³¼Æ¦r(§Y<>"")
¥BCells([B65536].End(xlUp).Row - 13, 2).Resize(1, 49)ªº¦PÄæ¤]¦³¼Æ¦r(§Y<>"")
¥BCells([B65536].End(xlUp).Row - 14, 2).Resize(1, 49)ªº¦PÄæ¤]¦³¼Æ¦r(§Y<>"")

­ã´£³¡ª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

Scott090

¦^´_ 11# Airman

   ¸Õ¬Ý¬Ý¬O§_²Å¦X»Ý¨D
          ¤µ¤éÁ`ªí(§¡­È±Æ§Ç).rar (90.38 KB)

¤U¸ü¦¸¼Æ: 4

2019-5-4 21:42

Airman

¦^´_ 12# ­ã´£³¡ªL
­ã¤j:±z¦n!
´ú¸Õ¦¨¥\~·P®¦^^

±z»¡ªº¨S¦³¿ù~
' If R < 10 Then xB.Close 0: GoTo 101
§ï¬°
If R < 2 Then xB.Close 0: GoTo 101  '·Ó¼ÒÀÀÀ³¸Ó¥Î³o¤@¦æ
µª®×¤~¬O¥¿½Tªº¡CÁÂÁ±z^^

Airman

¦^´_ 13# Scott090
Scott090¤j¤j:±z¦n!
¤£¦n·N«ä¡A2­Ó"²Î­p"Àɬ°2007ª©µLªk¶}±Ò®Ö¹ïµª®×¡F
¥Dµ{¦¡ÀÉÂI°õ¦æÁä~¨S¦³¤ÏÀ³^^"

Airman

¦^´_ 13# Scott090
Scott090¤j¤j:±z¦n!
¤£¦n·N«ä¡A¨S¦³ª`·N¨ì±zµ{¦¡¼g¦b¼Ò²Õ1^^"
¦b°õ¦æÀɲK¥[Main
¤w¥i¥¿½T°õ¦æ¡C

°õ¦æ«á~µª®×¥¿½T~´ú¸Õ¦¨¥\~·P®¦^^

¯S§O·PÁ±zªº¤å¦rµù¸Ñ^^

Scott090

¦^´_ 16# Airman


    ¬O§_¥i§iª¾¹ê»Ú¤WŲ§O¿ëÃѤF´X¦Ê­ÓÀɮסA¥Î¤F¦h¤Ö®É¶¡©O?

Airman

¦^´_ 12# ­ã´£³¡ªL

¤U¸ü (62.51 KB)

2019-5-5 17:17

¤U¸ü (60.48 KB)
¤µ¤éÁ`ªí(§¡­È±Æ§Ç)-(2019-04-09)_²Î­p

2019-5-5 17:19

­ã¤j¡J±z¦n!
¤£¦n·N«ä¡A¯à¦AÀ°¤p§Ì¥[¤@­Ó«ü©w¤é´Áªº¶}¼ú¸¹½X¶Ü^^"

»¡©ú¡J
·í²Î­pÀɮתº¤é´Á=DATAªºAÄæ¤é´Á®É¡A
«h±N²Î­pÀɮפºªº"Sample"¤u§@ªí¤§$B$1¡J$AX$1¦³¥X²{¸ÓAÄæ¤é´ÁªºD¡JJªº¼Æ¦r¼Ð¥Ü©³¦â~
=D¡JKªº¼Æ¦r¼Ð¥Ü6¸¹©³¦â¡F=Jªº¼Æ¦r¼Ð¥Ü43¸¹©³¦â¡C
¦p¸ÓDATAªºAÄæ¤é´ÁªºD¡JJ=""(§Y¨S¦³¥X²{¼Æ¦r)¡A«h³£¤£¼Ð¥Ü©³¦â¡C

PS¡J¦]¬°DATA©MÀɮצWºÙ¬O¥Ñ2­Ó¤£¦P³nÅé¤U¸üªº¡A©Ò¥H¤£¦P~
¦pªG³o¼Ë½s¼g·|«Ü³Â·Ð¡A´N½Ð±NDATAªºAÄæ¤é´Á®æ¦¡§ï¬°»P²Î­pÀɮצWºÙªº¤é´Á®æ¦¡¬Û¦P¡C

ÁÂÁ±z^^

Airman

¦^´_ 17# Scott090
Scott090¤j¤j:±z¦n!
¤£¦n·N«ä¡A¦]¬°«á¨Ó¤~ª¾¹D¶Q¸ÑµªÀÉ¡F¥²¶·±N­n§PŪªº©Ò¦³ÀɮצWºÙ»P¤é´Á¡A¥þ³¡¥ýµn¿ý¦b"FileNameSh"ªºAÄæ©MBÄæ¤~¯à°õ¦æ¡A
©Ò¥H¥Ø«eÁÙ¦b¬ã¨s«ç»ò­×§ï?¼È®É¨S¦³¦A´ú¸Õ¤F^^"

­ã¤jªº¸ÑµªÀÉ¡A¦³¸Õ¹L200­ÓÀÉ®×~·Pı¬O1¤À¦hÄÁ~¦]¬°¨S¦³¥[¼g­p®É½X¡A©Ò¥H¤£ª¾¥¿½Tªº¯Ó®É¬O¦h¤Ö?^^

Scott090

¦^´_ 19# Airman


    ©êºp¡A¸Õ¹BÂà«á¨S¦³ remark ' ®³±¼¡C
     ¤£¥Î¤H¤u¤JÀɦW
     ½Ð­«¸Õ
    Option Explicit
Option Base 1

''===================
Sub Main()
      Dim wb As Workbook, sh As Worksheet, shSample As Worksheet, fpath$
      Dim arColor%(7), arDATA
      Dim i%, j%, k%, fileNo%, RowNo%, colNo%
      Dim Cat$    'Àɮרt¦C¥N½X
      Dim colorNo%      '©³¦â¼Æ
      
      colorNo = 7
      colNo = 49
      ReDim arDATA(colorNo, colNo)
      
      Application.ScreenUpdating = False
      
      fpath = ThisWorkbook.Path
      
'¨ú±o±ýµû¦ôªºÀÉ®×
'================
   getFileNames
      
'¨úÀx¦s®æ©³¦âªíCaeColor
'==================
      Set shSample = ThisWorkbook.Sheets("Sample")
      With shSample
            colorNo = 7       '7ºØ©³¦â
            For i = 1 To colorNo
                 arColor(colorNo - i + 1) = .Cells(i + 1, 1).Interior.ColorIndex
           Next
      End With
      
      Set sh = ThisWorkbook.Sheets("FileNameSh")
      
      fileNo = 1: Cat = sh.Cells(1, 2)
      Do While sh.Cells(fileNo, 2) <> ""
            If sh.Cells(fileNo, 2) <> Cat Then GoSub FinishCatFile: Cat = sh.Cells(fileNo, 2)
            
                  DoEvents
                  Application.ScreenUpdating = False
                  
                  Set wb = Workbooks.Open(fpath & "\" & sh.Cells(fileNo, 1))
                  RowNo = [B65536].End(xlUp).Row
                  If RowNo < 10 Then GoTo NextFile          '­ì³W«h³] Rowno <10 «h¤£³B²z
                  
                  RowNo = RowNo - 1 - colorNo
                  For i = 1 To colorNo                '±q 1 ~ 7 ©³¦â
                        
                        For j = 1 To colNo            '±q 1~ 49 Äæ
                              For k = 0 To i - 1            '¬d®Ö³sÄò¬Û¦P©³¦â
                                    If RowNo - k = 1 Then GoTo NextFile       'Àɮתº¦³®Ä¦C¼Æ¤ñ©³¦â¼Æ¤Ö¡ACellsªº¦C¤w¨ì²Ä1¦C
                                    If Cells(RowNo - k, j + 1).Interior.ColorIndex <> arColor(i) Then GoTo NextCol
                              Next
                              arDATA(colorNo - i + 1, j) = arDATA(colorNo - i + 1, j) + 1
NextCol:
                        Next
NextColor:
                   Next
            
NextFile:
            wb.Close (fpath & "\" & sh.Cells(fileNo, 1))
            Set wb = Nothing
            fileNo = fileNo + 1
            
      Loop
      GoSub FinishCatFile           'For the last one date code catagory
      
Exit Sub

FinishCatFile:
      With shSample
            .[b2].Resize(colorNo, colNo) = arDATA
            .Copy
      End With
      Sheets("Sample").Name = "¤µ¤éÁ`ªí(§¡­È±Æ§Ç) - " & Cat & "_²Î­p"
      On Error Resume Next
      Kill fpath & "\" & "¤µ¤éÁ`ªí(§¡­È±Æ§Ç)-" & Cat & "_²Î­p.xls"
      On Error GoTo 0
      
      ActiveWorkbook.Close savechanges:=True, Filename:=fpath & "\" & "¤µ¤éÁ`ªí(§¡­È±Æ§Ç)-" & Cat & "_²Î­p.xls"
      ReDim arDATA(colorNo, colNo)        'clear contents
      Application.ScreenUpdating = True
Return
End Sub

'To get all file names  into a working sheet
'=============================
Sub getFileNames()
      Dim fs, Cat$
      Dim sh As Worksheet
      Dim fpath$
      Dim i%, j%, R%
      
      fpath = ThisWorkbook.Path
      On Error Resume Next
      Set sh = Sheets("FileNameSh")
      If Err.Number <> 0 Then Sheets.Add.Name = "FileNameSh": Set sh = ActiveSheet
      On Error GoTo 0
      
      sh.Cells.Clear
      
      With sh
            fs = Dir(fpath & "\*.*")
            Do Until fs = ""
                 Cat = Left(Right(fs, 16), 12)
                 If InStr(Cat, "(2019") <> 0 Then
                        R = R + 1
                        .Cells(R, 1) = fs
                        .Cells(R, 2) = Cat
                  End If
                  fs = Dir
            Loop
            
            With .Sort
                  .SortFields.Add Key:=[B:B]
                  .SetRange sh.UsedRange
                  .Apply
            End With
      End With
End Sub