Hsieh

¦^´_ 9# PJChen

ªí®æ®æ¦¡¤£¦P³y¦¨§xÂZ¡A¥²¶·¦b©Ò¦³¦r¦ê¤¤´M§ä·|¼W¥[¹B¦æ®É¶¡
PI_PO Records.rar (15.08 KB)

¤U¸ü¦¸¼Æ: 13

2012-5-15 22:21

Hsieh

¦^´_ 20# PJChen

¨º¬O¦]¬°§Aªº¤u§@ªí¤£¥u¬O¥u¦³PI¸òPO
³y¦¨TOTAL¨º¤@¦æ§ä¤£¨ìpcs©Ò­P

1. Sub ex()
   
2. Dim Sh As Worksheet, A As Range, Ar()
   
3. Set d = CreateObject("Scripting.Dictionary")
   
4. Application.ScreenUpdating = False
   
5. Application.DisplayAlerts = False
   
6. fd = ThisWorkbook.Path & "\" & "PI_PO\"
   
7. fs = Dir(fd & "*xls*")
   
8. Do Until fs = ""
   
9. With Workbooks.Open(fd & fs)
   
10. n = Split(fs, " ")(0)
    
11. s = InStr(n, "BCM") + 3
    
12. fn = Mid(n, s)
    
13.    For Each Sh In .Sheets
    
14.       With Sh
    
15.       If .Name <> "PO" Or .Name <> "PI" Then GoTo 10
    
16.       For Each C In .Range("A:B").SpecialCells(xlCellTypeConstants)
    
17.         If C Like "TOTAL*" Then Set A = C: Exit For
    
18.       Next
    
19.       If Not A Is Nothing Then
    
20.       Set b = A.EntireRow.Find("pcs")
    
21.       If Not b Is Nothing Then
    
22.         d(.Name & "¼Æ¶q") = b.Offset(, -1)
    
23.         d(.Name & "ª÷ÃB") = b.Offset(, 2)
    
24.       End With
    
25.       End If
    
26.       End With
    
27. 10
    
28.     Next
    
29.     ReDim Preserve Ar(y)
    
30.     Ar(y) = Array(fn, d("PI¼Æ¶q"), d("PIª÷ÃB"), d("PO¼Æ¶q"), d("POª÷ÃB"), fs)
    
31.     y = y + 1
    
32.     .Close
    
33.     d.RemoveAll
    
34. End With
    
35. fs = Dir
    
36. Loop
    
37. Sheets("Records").[A2].Resize(y, 6) = Application.Transpose(Application.Transpose(Ar))
    
38. Application.ScreenUpdating = True
    
39. Application.DisplayAlerts = True
    
40. End Sub

½Æ»s¥N½X

Hsieh

¦^´_ 22# PJChen

1. Sub ex()
   
2. Dim Sh As Worksheet, A As Range, Ar()
   
3. Set d = CreateObject("Scripting.Dictionary")
   
4. Application.ScreenUpdating = False
   
5. Application.DisplayAlerts = False
   
6. fd = ThisWorkbook.Path & "\" & "PI_PO\"
   
7. fs = Dir(fd & "*xls*")
   
8. Do Until fs = ""
   
9. With Workbooks.Open(fd & fs)
   
10. n = Split(fs, " ")(0)
    
11. s = InStr(n, "BCM") + 3
    
12. fn = Mid(n, s)
    
13.    For Each Sh In .Sheets
    
14.       With Sh
    
15.       If .Name <> "PO" Or .Name <> "PI" Then GoTo 10
    
16.       For Each C In .Range("A:B").SpecialCells(xlCellTypeConstants)
    
17.         If C Like "TOTAL*" Then Set A = C: Exit For
    
18.       Next
    
19.       If Not A Is Nothing Then
    
20.       Set b = A.EntireRow.Find("pcs")
    
21.       If Not b Is Nothing Then
    
22.         d(.Name & "¼Æ¶q") = b.Offset(, -1)
    
23.         d(.Name & "ª÷ÃB") = b.Offset(, 2)
    
24.       End If
    
25.       End If
    
26.       End With
    
27. 10
    
28.     Next
    
29.     ReDim Preserve Ar(y)
    
30.     Ar(y) = Array(fn, d("PI¼Æ¶q"), d("PIª÷ÃB"), d("PO¼Æ¶q"), d("POª÷ÃB"), fs)
    
31.     y = y + 1
    
32.     .Close
    
33.     d.RemoveAll
    
34. End With
    
35. fs = Dir
    
36. Loop
    
37. Sheets("Records").[A2].Resize(y, 6) = Application.Transpose(Application.Transpose(Ar))
    
38. Application.ScreenUpdating = True
    
39. Application.DisplayAlerts = True
    
40. End Sub

½Æ»s¥N½X

Hsieh

¦^´_ 25# PJChen
±ø¥óÀ³¸Ó¬OAND¤~¹ï
If .Name <> "PO" And .Name <> "PI" Then GoTo 10
¾ã­Óµ{¦¡½X´N¬O¦Û°Ê±NÀɦW¤Á³Î¥X½s¸¹A¡BFÄ椣»Ý¶ñ¼g¡A°õ¦æ§¹´N·|¨q¥X¨Ó¤F

1. Sub get_value()
   
2. Dim Sh As Worksheet, A As Range, Ar()
   
3. Set d = CreateObject("Scripting.Dictionary")
   
4. Application.ScreenUpdating = False
   
5. Application.DisplayAlerts = False
   
6. fd = ThisWorkbook.Path & "\" & "PI_PO\"
   
7. fs = Dir(fd & "*xls*")
   
8. Do Until fs = ""
   
9. With Workbooks.Open(fd & fs)
   
10. n = Split(fs, " ")(0)
    
11. s = InStr(n, "BCM") + 3
    
12. fn = Mid(n, s)
    
13.    For Each Sh In .Sheets
    
14.       With Sh
    
15.       If .Name <> "PO" And .Name <> "PI" Then GoTo 10
    
16.       For Each C In .Range("A:B").SpecialCells(xlCellTypeConstants)
    
17.         If C Like "TOTAL*" Then Set A = C: Exit For
    
18.       Next
    
19.       If Not A Is Nothing Then
    
20.       Set b = A.EntireRow.Find("pcs")
    
21.       If Not b Is Nothing Then
    
22.         d(.Name & "¼Æ¶q") = b.Offset(, -1)
    
23.         d(.Name & "ª÷ÃB") = b.Offset(, 2)
    
24.       End If
    
25.       End If
    
26.       End With
    
27. 10
    
28.     Next
    
29.     ReDim Preserve Ar(y)
    
30.     Ar(y) = Array(fn, d("PI¼Æ¶q"), d("PIª÷ÃB"), d("PO¼Æ¶q"), d("POª÷ÃB"), fs)
    
31.     y = y + 1
    
32.     .Close
    
33.     d.RemoveAll
    
34. End With
    
35. fs = Dir
    
36. Loop
    
37. Sheets("Records").[A2].Resize(y, 6) = Application.Transpose(Application.Transpose(Ar))
    
38. Application.ScreenUpdating = True
    
39. Application.DisplayAlerts = True
    
40. End Sub

½Æ»s¥N½X

Hsieh

¦^´_ 27# PJChen

¤u§@ªí¦WºÙ¤£²Å¦h¤FªÅ¥ÕÁä

1. Sub get_value()
   
2. Dim Sh As Worksheet, A As Range, Ar(), B As Range, B1 As Range
   
3. Set d = CreateObject("Scripting.Dictionary")
   
4. Application.ScreenUpdating = False
   
5. Application.DisplayAlerts = False
   
6. fd = ThisWorkbook.Path & "\" & "PI_PO\"
   
7. fs = Dir(fd & "*xls*")
   
8. Do Until fs = ""
   
9. With Workbooks.Open(fd & fs)
   
10. n = Split(fs, " ")(0)
    
11. s = InStr(n, "BCM") + 3
    
12. fn = Mid(n, s)
    
13.    For Each Sh In .Sheets
    
14.       With Sh
    
15.       If Trim(.Name) <> "PO" And Trim(.Name) <> "PI" Then GoTo 10
    
16.       For Each C In .Range("A:B").SpecialCells(xlCellTypeConstants)
    
17.         If C Like "TOTAL*" Then Set A = C: Exit For
    
18.       Next
    
19.       If Not A Is Nothing Then
    
20.       Set B = A.EntireRow.Find("pcs")
    
21.       Set B1 = A.EntireRow.Find("*", after:=B)
    
22.       
    
23.       If Not B Is Nothing Then
    
24.         d(Trim(.Name) & "¼Æ¶q") = B.Offset(, -1)
    
25.         c1 = A.EntireRow.Find("*", after:=B1)
    
26.         d(Trim(.Name) & "ª÷ÃB") = c1
    
27.       End If
    
28.       End If
    
29.       Set A = Nothing
    
30.       End With
    
31. 10
    
32.     Next
    
33.     ReDim Preserve Ar(y)
    
34.     Ar(y) = Array(fn, d("PI¼Æ¶q"), d("PIª÷ÃB"), d("PO¼Æ¶q"), d("POª÷ÃB"), fs)
    
35.     y = y + 1
    
36.     .Close
    
37.     d.RemoveAll
    
38. End With
    
39. fs = Dir
    
40. Loop
    
41. Sheets("Records").[A2].Resize(y, 6) = Application.Transpose(Application.Transpose(Ar))
    
42. Application.ScreenUpdating = True
    
43. Application.DisplayAlerts = True
    
44. End Sub

½Æ»s¥N½X

Hsieh

¦^´_ 34# PJChen

1. Sub get_value()
   
2. Dim Sh As Worksheet, a As Range, Ar(), B As Range, B1 As Range
   
3. Set d = CreateObject("Scripting.Dictionary")
   
4. Application.ScreenUpdating = False
   
5. Application.DisplayAlerts = False
   
6. fd = ThisWorkbook.Path & "\" & "2011 PI_PO\"
   
7. fs = Dir(fd & "*xls*")
   
8. Do Until fs = ""
   
9. With Workbooks.Open(Filename:=fd & fs, UpdateLinks:=False)
   
10. n = Split(fs, " ")(0)
    
11. s = InStr(n, "BCM") + 3
    
12. fn = Mid(n, s)
    
13.    For Each Sh In .Sheets
    
14.       With Sh
    
15.       If Trim(.Name) <> "PO" And Trim(.Name) <> "PI" Then GoTo 10
    
16.       For Each c In .Range("A:B").SpecialCells(xlCellTypeConstants)
    
17.         If c Like "TOTAL*" Then Set a = c: Exit For
    
18.       Next
    
19.       If Not a Is Nothing Then
    
20.       Set B = a.EntireRow.Find("pcs")
    
21.       Set B1 = a.EntireRow.Find("*", after:=B)
    
22.       
    
23.       If Not B Is Nothing Then
    
24.         d(Trim(.Name) & "¼Æ¶q") = B.Offset(, -1)
    
25.         c1 = a.EntireRow.Find("*", after:=B1)
    
26.         d(Trim(.Name) & "ª÷ÃB") = c1
    
27.       End If
    
28.       End If
    
29.       Set a = Nothing
    
30.       End With
    
31. 10
    
32.     Next
    
33.     ReDim Preserve Ar(y)
    
34.     Ar(y) = Array(fn, d("PI¼Æ¶q"), d("PIª÷ÃB"), d("PO¼Æ¶q"), d("POª÷ÃB"), fs)
    
35.     y = y + 1
    
36.     .Close
    
37.     d.RemoveAll
    
38. End With
    
39. fs = Dir
    
40. Loop
    
41. Sheets("Records").[A2].Resize(y, 6) = Application.Transpose(Application.Transpose(Ar))
    
42. Application.ScreenUpdating = True
    
43. Application.DisplayAlerts = True
    
44. End Sub

½Æ»s¥N½X

Hsieh

¦^´_ 39# PJChen
¤@¦C¤¤¦P®É¦s¦bTOTAL»PPCS§@¬°§PÂ_¼Ð·Ç

1. Sub get_value()
   
2. Dim Sh As Worksheet, a As Range, Ar(), B As Range, B1 As Range
   
3. Set d = CreateObject("Scripting.Dictionary")
   
4. Application.ScreenUpdating = False
   
5. Application.DisplayAlerts = False
   
6. fd = ThisWorkbook.Path & "\" & "PI_PO\"
   
7. fs = Dir(fd & "*xls*")
   
8. Do Until fs = ""
   
9. With Workbooks.Open(Filename:=fd & fs, UpdateLinks:=False)
   
10. n = Split(fs, " ")(0)
    
11. s = InStr(n, "BCM") + 3
    
12. fn = Mid(n, s)
    
13.    For Each Sh In .Sheets
    
14.       With Sh
    
15.       If Trim(.Name) <> "PO" And Trim(.Name) <> "PI" Then GoTo 10
    
16.       ay = .UsedRange.Value
    
17.       For i = 1 To UBound(ay)
    
18.          mystr = UCase(Join(Application.Index(ay, i)))
    
19.          If InStr(mystr, "TOTAL") > 0 And InStr(mystr, "PCS") > 0 Then
    
20.             For j = 1 To UBound(ay, 2)
    
21.                If ay(i, j) = "PCS" Then d(Trim(.Name) & "¼Æ¶q") = ay(i, j - 1): yn = True
    
22.                If IsNumeric(ay(i, j)) And yn = True Then d(Trim(.Name) & "ª÷ÃB") = ay(i, j): yn = False: Exit For
    
23.             Next
    
24.          End If
    
25.       Next
    
26. 20
    
27.       End With
    
28. 10
    
29.     Next
    
30.     ReDim Preserve Ar(y)
    
31.     Ar(y) = Array(fn, d("PI¼Æ¶q"), d("PIª÷ÃB"), d("PO¼Æ¶q"), d("POª÷ÃB"), fs)
    
32.     y = y + 1
    
33.     .Close
    
34.     d.RemoveAll
    
35. End With
    
36. fs = Dir
    
37. Loop
    
38. Sheets("Records").[A2].Resize(y, 6) = Application.Transpose(Application.Transpose(Ar))
    
39. Application.ScreenUpdating = True
    
40. Application.DisplayAlerts = True
    
41. End Sub

½Æ»s¥N½X

Hsieh

¦^´_ 41# PJChen

1. Sub get_value()
   
2. Dim Sh As Worksheet, a As Range, Ar(), B As Range, B1 As Range
   
3. Set d = CreateObject("Scripting.Dictionary")
   
4. Application.ScreenUpdating = False
   
5. Application.DisplayAlerts = False
   
6. fd = ThisWorkbook.Path & "\" & "PI_PO\"
   
7. fs = Dir(fd & "*xls*")
   
8. Do Until fs = ""
   
9. With Workbooks.Open(Filename:=fd & fs, UpdateLinks:=False)
   
10. n = Split(fs, " ")(0)
    
11. s = InStr(n, "BCM") + 3
    
12. fn = Mid(n, s)
    
13.    For Each Sh In .Sheets
    
14.       With Sh
    
15.       If Trim(.Name) <> "PO" And Trim(.Name) <> "PI" Then GoTo 10
    
16.       ay = .UsedRange.Value
    
17.       For i = 1 To UBound(ay)
    
18.          mystr = ""
    
19.          For j1 = 1 To UBound(ay, 2)
    
20.             mystr = IIf(mystr = "", UCase(Trim(.Cells(i, j1).Text)), mystr & Chr(10) & UCase(Trim(.Cells(i, j1).Text)))
    
21.          Next
    
22.          If Trim(Replace(mystr, Chr(10), "")) Like "TOTAL*PCS?*" Then
    
23.          ak = Split(mystr, "PCS")
    
24.          ax = Split(Trim(ak(0)), Chr(10))
    
25.          ap = Split(Trim(ak(1)), Chr(10))
    
26.                d(Trim(.Name) & "¼Æ¶q") = ax(UBound(ax) - 1)
    
27.                d(Trim(.Name) & "ª÷ÃB") = ap(2)
    
28.                Exit For
    
29.          End If
    
30.       Next
    
31.       End With
    
32. 10
    
33.     Next
    
34.     ReDim Preserve Ar(y)
    
35.     Ar(y) = Array(fn, d("PI¼Æ¶q"), d("PIª÷ÃB"), d("PO¼Æ¶q"), d("POª÷ÃB"), fs)
    
36.     y = y + 1
    
37.     .Close
    
38.     d.RemoveAll
    
39. End With
    
40. fs = Dir
    
41. Loop
    
42. Sheets("Records").[A2].Resize(y, 6) = Application.Transpose(Application.Transpose(Ar))
    
43. Application.ScreenUpdating = True
    
44. Application.DisplayAlerts = True
    
45. End Sub

½Æ»s¥N½X