返回列表 上一主題 發帖

[發問] [發問]EXCEL 資料查尋回傳問題

yen956

帖子
522 
主題
36 
精華
1 
積分
603 
點名
0  
作業系統
win xp sp3 
軟體版本
Office 2003 
閱讀權限
50 
性別
男 
註冊時間
2012-12-13 
最後登錄
2021-7-11 
1# 跳轉到 »
發表於 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
複製代碼
總表.gif

TOP

        靜思自在 : 修行要繫緣修心，藉事練心，隨處養心。
返回列表 上一主題