ªð¦^¦Cªí ¤W¤@¥DÃD µo©«

[µo°Ý] ¦p¦ó¶×¤JEXCEL¸ê®Æ?

¦^´_ 9# PJChen

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

TOP

¦^´_ 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
¾Ç®üµL²P_¤£®¢¤U°Ý

TOP

¦^´_ 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
¾Ç®üµL²P_¤£®¢¤U°Ý

TOP

¦^´_ 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
¾Ç®üµL²P_¤£®¢¤U°Ý

TOP

¦^´_ 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
¾Ç®üµL²P_¤£®¢¤U°Ý

TOP

¦^´_ 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
¾Ç®üµL²P_¤£®¢¤U°Ý

TOP

¦^´_ 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
¾Ç®üµL²P_¤£®¢¤U°Ý

TOP

¥»©«³Ì«á¥Ñ Hsieh ©ó 2012-5-19 14:49 ½s¿è

¦^´_ 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
¾Ç®üµL²P_¤£®¢¤U°Ý

TOP

        ÀR«ä¦Û¦b : ¤H¨ÆªºÁ}Ãø»PµZ¿i¡A´N¬O¤@ºØ¦ÒÅç¡C
ªð¦^¦Cªí ¤W¤@¥DÃD