返回列表 上一主題 發帖

[發問] 請教改良方法，謝謝~

198188

帖子
438 
主題
67 
精華
0 
積分
531 
點名
30  
作業系統
win7 
軟體版本
office 2010 
閱讀權限
50 
性別
男 
註冊時間
2012-10-30 
最後登錄
2024-11-19 
1# 跳轉到 » 倒序看帖
打印
tT
發表於 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
　暱稱: 隨風飄蕩的羽毛
　頭銜: [御用]潛水艇

高中生Rank: 3Rank: 3

帖子
852 
主題
79 
精華
0 
積分
918 
點名
0  
作業系統
Windows 7 , XP 
軟體版本
Office 2007, Office 2003,Office 2010,YoZo Office 
閱讀權限
50 
性別
男 
來自
宇宙 
註冊時間
2011-4-8 
最後登錄
2024-2-21 
2#
發表於 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
複製代碼

  多做多想多學習，少看少錯少迷途

  多做=多多練習，多多編寫。
  多想=想想為什麼人家程式要那樣寫，如果換成自己，又會怎寫。
  多學習=學習人家的發問並解答，學習人家的寫法

  少看=只看不做也枉然

TOP

        靜思自在 : 滴水成河。粒米成蘿，勿輕己靈，勿以善小而不為。
返回列表 上一主題