返回列表 上一主題 發帖

[發問] 增加同名稱工作表並將資料複製到新工作表

register313
　頭銜: 麻辣 路人甲

大學生Rank: 4

帖子
967 
主題
0 
精華
0 
積分
1001 
點名
0  
作業系統
WIN XP 
軟體版本
OFFICE 2003 
閱讀權限
50 
性別
男 
來自
台北 
註冊時間
2010-11-29 
最後登錄
2022-5-17 

2012龍年全勤獎章熱烈參與勳章
1# 跳轉到 »
發表於 2012-3-4 23:01 | 顯示全部帖子
本帖最後由 register313 於 2012-3-4 23:57 編輯
  1. Sub Filter()
  2. Sheets("總表").Select
  3. C = Sheets("總表").[B65536].End(xlUp).Row
  4. D = Sheets("資料庫").[E65536].End(xlUp).Row
  5. Rng2 = Sheets("資料庫").Range("E4:E" & D)
  6. With Sheets("總表")
  7.   For Each R In Rng2
  8.      For Each sh In ThisWorkbook.Sheets
  9.        Application.DisplayAlerts = False
  10.        If sh.Name = R Then
  11.           sh.Delete
  12.        End If
  13.        Application.DisplayAlerts = True
  14.      Next
  15.      Set sh = Sheets.Add(after:=Sheets(Sheets.Count))
  16.      sh.Name = R
  17.      .Range("B4:O" & C).AutoFilter Field:=3, Criteria1:=R
  18.      If .FilterMode Then
  19.         .AutoFilter.Range.SpecialCells(12).Copy Sheets(R).Cells(3, 2)
  20.         .Rows("2:3").Copy Sheets(R).Cells(2, 1)
  21.      End If
  22.      Sheets(R).Select
  23.      For Each A In Range("D4:D" & [D65536].End(xlUp).Row)
  24.          If A <> "" Then
  25.             A.Offset(0, -2) = A.Row - 3
  26.          End If
  27.      Next
  28.   Next
  29.   .Range("B4:O" & C).AutoFilter
  30. End With
  31. End Sub
複製代碼

TOP

register313
　頭銜: 麻辣 路人甲

大學生Rank: 4

帖子
967 
主題
0 
精華
0 
積分
1001 
點名
0  
作業系統
WIN XP 
軟體版本
OFFICE 2003 
閱讀權限
50 
性別
男 
來自
台北 
註冊時間
2010-11-29 
最後登錄
2022-5-17 

2012龍年全勤獎章熱烈參與勳章
2#
發表於 2012-3-4 23:56 | 顯示全部帖子
回復 6# b9208
略作修改
  1. Sub Filter()
  2. Sheets("總表").Select
  3. C = Sheets("總表").[B65536].End(xlUp).Row
  4. D = Sheets("資料庫").[E65536].End(xlUp).Row
  5. Rng2 = Sheets("資料庫").Range("E4:E" & D)
  6. With Sheets("總表")
  7.   For Each R In Rng2
  8.      For Each sh In ThisWorkbook.Sheets
  9.        Application.DisplayAlerts = False
  10.        If sh.Name = R Then
  11.           sh.Delete
  12.        End If
  13.        Application.DisplayAlerts = True
  14.      Next
  15.      Set sh = Sheets.Add(after:=Sheets(Sheets.Count))
  16.      sh.Name = R
  17.      .Range("B4:O" & C).AutoFilter Field:=3, Criteria1:=R
  18.      If .FilterMode Then
  19.         .AutoFilter.Range.SpecialCells(12).Copy Sheets(R).Cells(3, 2)
  20.         .Rows("2:3").Copy Sheets(R).Cells(2, 1)
  21.      End If
  22.      Sheets(R).Select
  23.      For Each A In Range("D4:D" & [D65536].End(xlUp).Row)
  24.          If A <> "" Then
  25.             A.Offset(0, -2) = A.Row - 3
  26.          End If
  27.      Next
  28.   Next
  29.   .Range("B4:O" & C).AutoFilter
  30. End With
  31. End Sub
複製代碼
WORK.rar (22.12 KB)

TOP

        靜思自在 : 好事要提得起，是非要放得下，成就別人即是成就自己。
返回列表 上一主題