Board logo

標題: [發問] 請教改良方法，謝謝~ [打印本頁]
作者: 198188    時間: 2012-12-12 09:25     標題: 請教改良方法，謝謝~

  1. Sub Detail()
  2. Dim FRng As Range
  3. Dim A As Range, Rng As Range
  4. Dim i As Integer
  5. Dim LastRec As Integer
  6. Dim k As Integer
  7. Dim j As Integer
  8.    
  9.     k = Sheets("state").Range("A1").CurrentRegion.Rows.Count
  10.          For j = 2 To k
  11.      If IsError(Application.VLookup(Worksheets("state").Range("A" & j).Value, Sheets("Result").Range("A:B"), 1, False)) Then
  12.              Sheets("State").Cells(j, "B") = Worksheets("Result").Range("S" & j).Value
  13.              Sheets("State").Cells(j, "O") = Worksheets("Result").Range("L" & j).Value
  14.              Sheets("State").Cells(j, "F") = Worksheets("Result").Range("E" & j).Value
  15.              Sheets("State").Cells(j, "K") = Worksheets("Result").Range("U" & j).Value
  16.              Sheets("State").Cells(j, "L") = Worksheets("Result").Range("V" & j).Value
  17.              Sheets("State").Cells(j, "P") = Worksheets("Result").Range("AL" & j).Value
  18.              Sheets("State").Cells(j, "Q") = Worksheets("Result").Range("Q" & j).Value
  19.              Sheets("State").Cells(j, "R") = Worksheets("Result").Range("M" & j).Value
  20.              Sheets("State").Cells(j, "S") = Worksheets("Result").Range("N" & j).Value
  21.              Sheets("State").Cells(j, "T") = Worksheets("Result").Range("X" & j).Value
  22.              Sheets("State").Cells(j, "U") = Worksheets("Result").Range("Z" & j).Value
  23.              Sheets("State").Cells(j, "W") = Worksheets("Result").Range("K" & j).Value
  24.              Sheets("State").Cells(j, "X") = Worksheets("Result").Range("C" & j).Value
  25.             
  26.             End If
  27.        Next

  29. fs = "W:\PIHK\NEW香港辦公室正本收放單記錄FROM 01-MAR-2012 to current(updated).xlsx"
  30. Set Wb = Workbooks.Open(fs)
  31. With ThisWorkbook.Worksheets("State")
  32. For Each A In .Range(.[A2], .Range("A1").End(xlDown))
  33.      Set FRng = Wb.Sheets("收單記錄").Range("C:C").Find(A, lookat:=xlWhole, SearchDirection:=xlPrevious)
  34.      If Not FRng Is Nothing Then
  35.            A.Offset(, 9) = FRng.Offset(, 4).Value
  36.            If Rng Is Nothing Then Set Rng = A.Offset(, 7) Else Set Rng = Union(Rng, A.Offset(, 7))
  37.         End If
  38.            Set FRng = Nothing
  39. Next
  40. End With
  41. Wb.Close 0

  43.   fs = "W:\PIHK\NEW香港辦公室正本收放單記錄FROM 01-MAR-2012 to current(updated).xlsx"
  44. Set Wb = Workbooks.Open(fs)
  45. With ThisWorkbook.Worksheets("State")
  46. For Each A In .Range(.[A2], .Range("A1").End(xlDown))
  47.      Set FRng = Wb.Sheets("放單記錄").Range("C:C").Find(A, lookat:=xlWhole, SearchDirection:=xlPrevious)
  48.      If Not FRng Is Nothing Then
  49.            A.Offset(, 21) = FRng.Offset(, 4).Value
  50.            If Rng Is Nothing Then Set Rng = A.Offset(, 21) Else Set Rng = Union(Rng, A.Offset(, 21))
  51.         End If
  52.            Set FRng = Nothing
  53. Next
  54. End With
  55. Wb.Close 0

  57. fs = "W:\Payment Daily Report\Brazil shipment schedule.xlsx"
  58.   Set Wb = Workbooks.Open(fs)
  59. With ThisWorkbook.Worksheets("State")
  60. For Each A In .Range(.[A2], .Range("A1").End(xlDown))
  61.      Set FRng = Wb.Sheets("sheet1").Range("D:D").Find(A, lookat:=xlWhole, SearchDirection:=xlPrevious)
  62.      If Not FRng Is Nothing Then
  63.            A.Offset(, 7) = FRng.Offset(, 10).Value
  64.            If Rng Is Nothing Then Set Rng = A.Offset(, 5) Else Set Rng = Union(Rng, A.Offset(, 5))
  65.         End If
  66.            Set FRng = Nothing
  67. Next
  68. End With
  69. Wb.Close 0

  71. fs = "W:\Payment Daily Report\daily doc.xlsx"

  73. 'fs = ThisWorkbook.Path & "\payment report 2012.xlsx"
  74. Set Wb = Workbooks.Open(fs)
  75. With ThisWorkbook.Worksheets("State")
  76. For Each A In .Range(.[A2], .Range("A1").End(xlDown))
  77.      Set FRng = Wb.Sheets("DAILY").Range("D:D").Find(A, lookat:=xlWhole, SearchDirection:=xlPrevious)
  78.      If Not FRng Is Nothing Then
  79.            A.Offset(, 13) = FRng.Offset(, 3).Value
  80.            If Rng Is Nothing Then Set Rng = A.Offset(, 11) Else Set Rng = Union(Rng, A.Offset(, 11))
  81.         End If
  82.            Set FRng = Nothing
  83. Next
  84. End With
  85. Wb.Close 0

  87.   fs = "W:\Payment Daily Report\JPMHK RECEIVED RECORD.xlsx"
  88. Set Wb = Workbooks.Open(fs)
  89. With ThisWorkbook.Worksheets("State")
  90. For Each A In .Range(.[A2], .Range("A1").End(xlDown))
  91.      Set FRng = Wb.Sheets("NEW TC ITEMS").Range("C:C").Find(A, lookat:=xlWhole, SearchDirection:=xlPrevious)
  92.      If Not FRng Is Nothing Then
  93.            A.Offset(, 8) = FRng.Offset(, 10).Value
  94.            If Rng Is Nothing Then Set Rng = A.Offset(, 6) Else Set Rng = Union(Rng, A.Offset(, 6))
  95.         End If
  96.            Set FRng = Nothing
  97. Next
  98. End With
  99. Wb.Close 0

  101.    fs = "W:\Payment Daily Report\Outstanding Payments.xlsm"
  102. Set Wb = Workbooks.Open(fs)
  103. With ThisWorkbook.Worksheets("State")
  104. For Each A In .Range(.[A2], .Range("A1").End(xlDown))
  105.      Set FRng = Wb.Sheets("outstanding payments").Range("A:A").Find(A, lookat:=xlWhole, SearchDirection:=xlPrevious)
  106.      If Not FRng Is Nothing Then
  107.            A.Offset(, 6) = FRng.Offset(, 4).Value
  108.            If Rng Is Nothing Then Set Rng = A.Offset(, 4) Else Set Rng = Union(Rng, A.Offset(, 6))
  109.         End If
  110.        Set FRng = Nothing
  111. Next
  112. End With
  113. Wb.Close 0

  115.     fs = "W:\Payment Daily Report\payment report.xlsx"
  116. Set Wb = Workbooks.Open(fs)
  117. With ThisWorkbook.Worksheets("State")
  118. For Each A In .Range(.[A2], .Range("A1").End(xlDown))
  119.      Set FRng = Wb.Sheets("New form of payment report").Range("B:B").Find(A, lookat:=xlWhole, SearchDirection:=xlPrevious)
  120.      If Not FRng Is Nothing Then
  121.            A.Offset(, 12) = FRng.Offset(, 7).Value
  122.            If Rng Is Nothing Then Set Rng = A.Offset(, 10) Else Set Rng = Union(Rng, A.Offset(, 10))
  123.         End If
  124.            Set FRng = Nothing
  125. Next
  126. End With
  127. Wb.Close 0


  130. fs = "W:\Payment Daily Report\HK ETA update.xlsx"
  131. Set Wb = Workbooks.Open(fs)
  132. With ThisWorkbook.Worksheets("State")
  133. For Each A In .Range(.[A2], .Range("A1").End(xlDown))
  134.      Set FRng = Wb.Sheets("香港&海防單").Range("A:A").Find(A, lookat:=xlWhole, SearchDirection:=xlPrevious)
  135.      If Not FRng Is Nothing Then
  136.            A.Offset(, 2) = FRng.Offset(, 11).Value
  137.            If Rng Is Nothing Then Set Rng = A.Offset(, 2) Else Set Rng = Union(Rng, A.Offset(, 2))
  138.         End If
  139.            Set FRng = Nothing
  140. Next
  141. End With
  142. Wb.Close 0

  144.   fs = "W:\Payment Daily Report\Mainland ETA Update.xlsx"
  145. Set Wb = Workbooks.Open(fs)
  146. With ThisWorkbook.Worksheets("State")
  147. For Each A In .Range(.[A2], .Range("A1").End(xlDown))
  148.      Set FRng = Wb.Sheets("MAILAND ETA").Range("A:A").Find(A, lookat:=xlWhole, SearchDirection:=xlPrevious)
  149.      If Not FRng Is Nothing Then
  150.            A.Offset(, 3) = FRng.Offset(, 9).Value
  151.            If Rng Is Nothing Then Set Rng = A.Offset(, 3) Else Set Rng = Union(Rng, A.Offset(, 3))
  152.         End If
  153.            Set FRng = Nothing
  154. Next
  155. End With
  156. Wb.Close 0

  158. End Sub
複製代碼
另外下面這兩個可否改成如果在"W:\Payment Daily Report\HK ETA update.xlsx"Sheets("香港&海防單") 內找到A.Offset(, 2) = FRng.Offset(, 11).Value，如果找不到就在"W:\Payment Daily Report\Mainland ETA Update.xlsx" Sheets("MAILAND ETA")內找，如果找到就A.Offset(, 2) = FRng.Offset(, 9).Value，如果兩個都找不到就將A.Offset(, 2) 就不變，維持原本的資料。

fs = "W:\Payment Daily Report\HK ETA update.xlsx"
Set Wb = Workbooks.Open(fs)
With ThisWorkbook.Worksheets("State")
For Each A In .Range(.[A2], .Range("A1").End(xlDown))
     Set FRng = Wb.Sheets("香港&海防單").Range("A:A").Find(A, lookat:=xlWhole, SearchDirection:=xlPrevious)
     If Not FRng Is Nothing Then
           A.Offset(, 2) = FRng.Offset(, 11).Value
           If Rng Is Nothing Then Set Rng = A.Offset(, 2) Else Set Rng = Union(Rng, A.Offset(, 2))
        End If
           Set FRng = Nothing
Next
End With
Wb.Close 0

  fs = "W:\Payment Daily Report\Mainland ETA Update.xlsx"
Set Wb = Workbooks.Open(fs)
With ThisWorkbook.Worksheets("State")
For Each A In .Range(.[A2], .Range("A1").End(xlDown))
     Set FRng = Wb.Sheets("MAILAND ETA").Range("A:A").Find(A, lookat:=xlWhole, SearchDirection:=xlPrevious)
     If Not FRng Is Nothing Then
           A.Offset(, 3) = FRng.Offset(, 9).Value
           If Rng Is Nothing Then Set Rng = A.Offset(, 3) Else Set Rng = Union(Rng, A.Offset(, 3))
        End If
           Set FRng = Nothing
Next
End With
Wb.Close 0
作者: mark15jill    時間: 2012-12-12 10:51

回復 1# 198188

    在下提供幾個小建議..
1.
可以將 Worksheets("Result") 設為定數 ( 如 KK= Worksheets("Result"))
這樣的話

  2.              .Cells(j, "B") = KK.Range("S" & j).Value
  3.              .Cells(j, "O") = KK.Range("L" & j).Value
  4.              .Cells(j, "F") = KK.Range("E" & j).Value
  5.              .Cells(j, "K") = KK.Range("U" & j).Value
  6.              .Cells(j, "L") = KK.Range("V" & j).Value
  7.              .Cells(j, "P") = KK.Range("AL" & j).Value
  8.              .Cells(j, "Q") = KK.Range("Q" & j).Value
  9.              .Cells(j, "R") = KK.Range("M" & j).Value
  10.              .Cells(j, "S") = KK.Range("N" & j).Value
  11.              .Cells(j, "T") = KK.Range("X" & j).Value
  12.              .Cells(j, "U") = KK.Range("Z" & j).Value
  13.              .Cells(j, "W") = KK.Range("K" & j).Value
  14.              .Cells(j, "X") = KK.Range("C" & j).Value
複製代碼
2.開啟、複製檔案部份
稍微看了一下 有更動的地方僅( fs 、thisworkbook.worksheets("xxx") 、 A.Offset(,X))
這樣的話可以 考慮用 Select Case ... End Select 作替代 類似以下方法
  1. '如有9項
  2. for uuw = 1 to 9
  3.         select case uuw
  4.                 case 1
  5.                      fs = "W:\PIHK\NEW香港辦公室正本收放單記錄FROM 01-MAR-2012 to current(updated).xlsx"
  6.                      Set Wb = Workbooks.Open(fs)
  7.                      With ThisWorkbook.Worksheets("State")
  8.                             For Each A In .Range(.[A2], .Range("A1").End(xlDown))
  9.                                  Set FRng = Wb.Sheets("收單記錄").Range("C:C").Find(A, lookat:=xlWhole, SearchDirection:=xlPrevious)
  10.                                  If Not FRng Is Nothing Then
  11.                                       A.Offset(, 9) = FRng.Offset(, 4).Value
  12.                                       If Rng Is Nothing Then Set Rng = A.Offset(, 7) Else Set Rng = Union(Rng, A.Offset(, 7))
  13.                                       Set FRng = Nothing
  14.                                  end if
  15.                            Next
  16.                       End With


  19.                 case 2
  20.                 case 3
  21.                 case 4
  22.                 case 5
  23.                 case 6
  24.                 case 7
  25.                 case 8
  26.                 case 9       

  28.         end select
  29.                       Wb.Close 0
  30. next uuw
複製代碼




歡迎光臨 麻辣家族討論版版 (http://forum.twbts.com/)