Board logo

標題: [發問] 求助填入專案編號 [打印本頁]
作者: xandertco    時間: 2013-6-9 13:59     標題: 求助填入專案編號

小弟只會寫簡單的VBA及錄製巨集,所以求助各位先進, 謝謝!

檔案內有2個工作表,生產領退料明細及專案編號, 需將專案編號工作表內的專案編號填入生產領退料明細表內製令單號後面.
作者: xandertco    時間: 2013-6-10 08:29

本帖最後由 GBKEE 於 2013-6-10 15:05 編輯

[attach]15226[/attach]
作者: stillfish00    時間: 2013-6-10 19:53

回復 1# xandertco
試試吧
  1. Sub Test()
  2.     Dim r1 As Long, r2 As Long
  3.    
  4.     Application.ScreenUpdating = False

  6.     With Sheets("生產領退料明細表")
  7.         r1 = .Cells(.Rows.Count, "A").End(xlUp).Row - 1  '[合計]的上面一列
  8.         
  9.         ' A9 到 A680 中為常數文字的儲存格
  10.         With .Range(.[A9], .Cells(r1, "A")).SpecialCells(xlCellTypeConstants, xlTextValues)
  11.             For Each x In .Cells
  12.                 '對非製令單號的列
  13.                 If x.Value <> "製令單號" Then
  14.                     With Sheets("專案編號")
  15.                         .AutoFilterMode = False '取消自動篩選
  16.                         r2 = .Cells(.Rows.Count, "A").End(xlUp).Row     '以A欄找最大列數
  17.                         .Range("A1:B" & r2).AutoFilter Field:=1, Criteria1:=x.Value     '以x單號去篩選
  18.                         .Range("B2:B" & r2).SpecialCells(xlCellTypeVisible).Copy        '複製B欄可見欄
  19.                     End With
  20.                     x.Offset(, 16).PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, Transpose:=True   '轉置貼上到Q欄右方
  21.                 End If
  22.             Next
  23.         End With
  24.     End With
  25.    
  26.     Application.ScreenUpdating = True
  27. End Sub
複製代碼
作者: Hsieh    時間: 2013-6-11 10:19

回復 2# xandertco
  1. Sub 填入()
  2. Set d = CreateObject("Scripting.Dictionary")
  3. With Sheets("專案編號")
  4.    ar = .Range("A1").CurrentRegion.Value
  5.    For i = 2 To UBound(ar, 1)
  6.       d(ar(i, 1)) = IIf(d(ar(i, 1)) = "", ar(i, 2), d(ar(i, 1)) & "," & ar(i, 2))
  7.    Next
  8. End With
  9. With Sheets("生產領退料明細表")
  10.    For Each a In .Range("A:A").SpecialCells(xlCellTypeConstants)
  11.    If d(a.Value) <> "" Then
  12.       ay = Split(d(a.Value), ",")
  13.        a.Offset(, 16).Resize(, UBound(ay) + 1) = ay
  14.     End If
  15.    Next
  16. End With
  17. End Sub
複製代碼
作者: stillfish00    時間: 2013-6-11 12:27

回復 4# Hsieh
學習了，這代碼好多了，
的確應該盡量少用複製貼上比較好。
作者: xandertco    時間: 2013-6-18 08:20

謝謝各位先進的幫忙!



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