- 帖子
- 522
- 主題
- 36
- 精華
- 1
- 積分
- 603
- 點名
- 0
- 作業系統
- win xp sp3
- 軟體版本
- Office 2003
- 閱讀權限
- 50
- 性別
- 男
- 註冊時間
- 2012-12-13
- 最後登錄
- 2021-7-11
|
3#
發表於 2015-10-30 18:24
| 只看該作者
試試VBA:- Option Explicit
- '副VBA
- '將各表的品項編號全部匯入總表的欄B(用不重覆篩選)
- Sub 取得全部品項編號()
- Dim sh2 As Worksheet
- Dim i, shCnt, LastRow1, LastRow2 As Integer
- Set sh2 = Sheets("總表")
- Dim Rng1, Rng2 As Range
- '清除工作區
- sh2.[A3:IU65536].ClearContents
- shCnt = ThisWorkbook.Sheets.Count
-
- '將品項編號全部匯入總表的欄IU
- For i = 1 To shCnt
- If Sheets(i).Name <> sh2.Name Then
- LastRow1 = Sheets(i).[B65536].End(xlUp).Row
- LastRow2 = sh2.[IU65536].End(xlUp).Row + 1
- Sheets(i).[B3].Resize(LastRow1 - 2, 1).Copy sh2.Cells(LastRow2, 255)
- End If
- Next
- '並將總表的欄IU的品項編號,用不重覆篩選到總表的欄A
- sh2.[IU2:IU65536].AdvancedFilter Action:=xlFilterCopy, _
- CopyToRange:=sh2.[A2], Unique:=True
- '清除暫存區
- sh2.[IU3:IU65536].ClearContents
- End Sub
- '主VBA
- Private Sub 建立總表_Click()
- Dim sh2 As Worksheet
- Dim i, j, shCnt, LastRow1, Row2, LastCol2 As Integer
- Dim FindStr As String
- Dim Rng1, FindRng As Range
- Set sh2 = Sheets("總表")
- sh2.Activate
- shCnt = ThisWorkbook.Sheets.Count
- 取得全部品項編號
- For i = 1 To shCnt
- If Sheets(i).Name <> sh2.Name Then
- LastRow1 = Sheets(i).[B65536].End(xlUp).Row
- For j = 3 To LastRow1
- Set Rng1 = Sheets(i).Cells(j, 2)
- 'sh2.[A:A]是欲搜尋範, 若搜尋到 FindStr 則存入 FindRng, 否則 FindRng=Nothing
- FindStr = Rng1
- Set FindRng = sh2.Range("A:A").Find(FindStr, lookat:=1)
- If Not FindRng Is Nothing Then
- LastCol2 = sh2.Cells(FindRng.Row, 255).End(xlToLeft).Column + 1
- FindRng.Offset(0, LastCol2 - 1) = Sheets(i).Cells(j, 12) '生產日期
- FindRng.Offset(0, LastCol2) = Sheets(i).Cells(j, 13) '有效日期
- End If
- Next
- End If
- Next
- sh2.[A2].Select
- End Sub
|
|
