Board logo

標題: [發問] [發問]EXCEL 資料查尋回傳問題 [打印本頁]
作者: hanachau    時間: 2015-6-9 11:57     標題: [發問]EXCEL 資料查尋回傳問題

本帖最後由 hanachau 於 2015-6-9 11:59 編輯

[attach]21139[/attach]
圖一,A欄是進貨日期,根據進貨日期流水日往下填,B欄是品項編號,L欄是生產日期,M欄是有效日期,
有時同一天同一商品會有不同的廠商進貨,不同批貨生產日期和有效日期不同,因為進貨日期不同或進貨廠商不同,
所以B欄的品項編號B1有B58也有
[attach]21140[/attach]
希望能匯整成圖二.可以清楚知道每個品項每一批的生產日期和有效期限,
因為填表的都是外國人,不想增加他們的負擔了,有可以不增加圖一表格欄列,但可增加工作表(圖二)的方法嗎?

PS,爬文爬了很久,有試著使用index/match/row/column但可能我太笨了,都没有成功,
主要問題是,單一進貨品項找的到,但同一日同一品項進貨二次的就不行,
希望高手大大們能幫個忙,教學一下,謝謝
作者: hcm19522    時間: 2015-10-20 10:34

http://blog.xuite.net/hcm19522/twblog/351072867
作者: yen956    時間: 2015-10-30 18:24

試試VBA:
  1. Option Explicit
  2. '副VBA
  3. '將各表的品項編號全部匯入總表的欄B(用不重覆篩選)
  4. Sub 取得全部品項編號()
  5.     Dim sh2 As Worksheet
  6.     Dim i, shCnt, LastRow1, LastRow2 As Integer
  7.     Set sh2 = Sheets("總表")
  8.     Dim Rng1, Rng2 As Range
  9.     '清除工作區
  10.     sh2.[A3:IU65536].ClearContents
  11.     shCnt = ThisWorkbook.Sheets.Count
  12.    
  13.     '將品項編號全部匯入總表的欄IU
  14.     For i = 1 To shCnt
  15.         If Sheets(i).Name <> sh2.Name Then
  16.             LastRow1 = Sheets(i).[B65536].End(xlUp).Row
  17.             LastRow2 = sh2.[IU65536].End(xlUp).Row + 1
  18.             Sheets(i).[B3].Resize(LastRow1 - 2, 1).Copy sh2.Cells(LastRow2, 255)
  19.         End If
  20.     Next
  21.     '並將總表的欄IU的品項編號,用不重覆篩選到總表的欄A
  22.     sh2.[IU2:IU65536].AdvancedFilter Action:=xlFilterCopy, _
  23.         CopyToRange:=sh2.[A2], Unique:=True
  24.     '清除暫存區
  25.     sh2.[IU3:IU65536].ClearContents
  26. End Sub
  27. '主VBA
  28. Private Sub 建立總表_Click()
  29.     Dim sh2 As Worksheet
  30.     Dim i, j, shCnt, LastRow1, Row2, LastCol2 As Integer
  31.     Dim FindStr As String
  32.     Dim Rng1, FindRng As Range
  33.     Set sh2 = Sheets("總表")
  34.     sh2.Activate
  35.     shCnt = ThisWorkbook.Sheets.Count
  36.     取得全部品項編號
  37.     For i = 1 To shCnt
  38.         If Sheets(i).Name <> sh2.Name Then
  39.             LastRow1 = Sheets(i).[B65536].End(xlUp).Row
  40.             For j = 3 To LastRow1
  41.                 Set Rng1 = Sheets(i).Cells(j, 2)
  42.                 'sh2.[A:A]是欲搜尋範, 若搜尋到 FindStr 則存入 FindRng, 否則 FindRng=Nothing
  43.                 FindStr = Rng1
  44.                 Set FindRng = sh2.Range("A:A").Find(FindStr, lookat:=1)
  45.                 If Not FindRng Is Nothing Then
  46.                    LastCol2 = sh2.Cells(FindRng.Row, 255).End(xlToLeft).Column + 1
  47.                    FindRng.Offset(0, LastCol2 - 1) = Sheets(i).Cells(j, 12)   '生產日期
  48.                    FindRng.Offset(0, LastCol2) = Sheets(i).Cells(j, 13)       '有效日期
  49.                 End If
  50.             Next
  51.         End If
  52.     Next
  53.     sh2.[A2].Select
  54. End Sub
複製代碼
[attach]22274[/attach]



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