12
返回列表 上一主題 發帖

[發問] 抓取篩選後儲存格內容至對應的工作表

Michelle-W

帖子
63 
主題
13 
精華
0 
積分
122 
點名
0  
作業系統
Windows 
軟體版本
office2007 
閱讀權限
20 
性別
女 
註冊時間
2015-4-22 
最後登錄
2019-7-19 
1# 跳轉到 » 倒序看帖
打印
tT
發表於 2016-7-14 15:42 | 只看該作者

[發問] 抓取篩選後儲存格內容至對應的工作表

各位好!~
我之前有請教過自動抓取後面有標註的方法，但那時候資料比較少
現在資料變多了
目前有7位人員(B1:H1)，我都用相同的程式碼複製再複製
但後續還會增加人員(假設B1:K1)，我得再次修改程式碼
請問有沒有什麼樣的寫法，可以自動抓取(B1:K1)到對應的工作表內
(因為後續還有各個月份需要新增上去QQ，人員隨時會增加，而專屬的工作表資料是累加的)


再次感謝 :)
資料.rar (837.08 KB) 的)
收藏 分享

c_c_lai

帖子
2035 
主題
24 
精華
0 
積分
2031 
點名
0  
作業系統
Win7 
軟體版本
Office2010 
閱讀權限
100 
性別
男 
註冊時間
2012-3-22 
最後登錄
2024-2-1 
2#
發表於 2016-7-14 19:15 | 只看該作者
回復 1# Michelle-W
試試看！
  1. Sub Ex()
  2.     Dim lg As Variant, ctn As Variant, xi As Integer
  3.     Dim dic As Object, sp As Variant, sh As Worksheet
  4.    
  5.     Set sh = Worksheets("05月")
  6.     Set dic = CreateObject("scripting.dictionary")
  7.    
  8.     With sh
  9.         For Each lg In .Range("B1:I1")
  10.             .Select
  11.             
  12.             dic(lg.Value) = ""
  13.             For Each ctn In .Range("A2:A7")
  14.                 If ctn.Offset(, lg.Column - 1) = "V" Then
  15.                     dic(lg.Value) = dic(lg.Value) + IIf(dic(lg.Value) = "", "", ",") + ctn.Value
  16.                 End If
  17.             Next
  18.             sp = Split(dic(lg.Value), ",")
  19.             '  Cells(15, lg.Column).Resize(UBound(sp) + 1) = Application.Transpose(Array(sp))    '  展示用
  20.             
  21.             For xi = 1 To Worksheets.Count
  22.                 If Worksheets(xi).Name = lg.Value Then Worksheets(xi).Select: Exit For
  23.             Next xi
  24.             If xi > Worksheets.Count Then
  25.                  Sheets.Add After:=Sheets(Worksheets.Count)
  26.                  ActiveSheet.Name = lg.Value
  27.             End If
  28.             With Worksheets(lg.Value)
  29.                 .[A1] = sh.[A1]
  30.                 .[B1] = lg.Value
  31.                 .[A2].Resize(UBound(sp) + 1) = Application.Transpose(Array(sp))
  32.                 .[B2].Resize(UBound(sp) + 1) = "V"
  33.             End With
  34.         Next
  35.     End With
  36. End Sub
複製代碼

TOP

Michelle-W

帖子
63 
主題
13 
精華
0 
積分
122 
點名
0  
作業系統
Windows 
軟體版本
office2007 
閱讀權限
20 
性別
女 
註冊時間
2015-4-22 
最後登錄
2019-7-19 
3#
發表於 2016-7-14 21:01 | 只看該作者
回復 2# c_c_lai


會出現1004的錯誤QQ

偵錯反黃的是這句
ActiveSheet.Name = lg.Value
這組程式碼太複雜了，我還看不懂>"<


在麻煩您幫忙看看
再次再次的感謝

TOP

Kubi

帖子
163 
主題
1 
精華
0 
積分
170 
點名
0  
作業系統
Window 7 
軟體版本
Office 2007 
閱讀權限
20 
性別
男 
註冊時間
2010-9-5 
最後登錄
2022-7-20 
4#
發表於 2016-7-15 13:51 | 只看該作者
回復 1# Michelle-W
請參考。
資料-1.rar (30.43 KB)

TOP

Michelle-W

帖子
63 
主題
13 
精華
0 
積分
122 
點名
0  
作業系統
Windows 
軟體版本
office2007 
閱讀權限
20 
性別
女 
註冊時間
2015-4-22 
最後登錄
2019-7-19 
5#
發表於 2016-7-15 16:31 | 只看該作者
回復 4# Kubi


非常感謝您的指點~~
還想請教一下...
若是假設B欄只是要記錄時間
(沒有專屬工作表，但要連同資料一起貼到專屬的工作表裡面的話)
以這組程式碼有辦法做更改嗎?

再次感謝 :)
資料-2.rar (27.23 KB)

TOP

c_c_lai

帖子
2035 
主題
24 
精華
0 
積分
2031 
點名
0  
作業系統
Win7 
軟體版本
Office2010 
閱讀權限
100 
性別
男 
註冊時間
2012-3-22 
最後登錄
2024-2-1 
6#
發表於 2016-7-15 18:15 | 只看該作者
回復 3# Michelle-W

資料.rar (1.1 MB)

TOP

Kubi

帖子
163 
主題
1 
精華
0 
積分
170 
點名
0  
作業系統
Window 7 
軟體版本
Office 2007 
閱讀權限
20 
性別
男 
註冊時間
2010-9-5 
最後登錄
2022-7-20 
7#
發表於 2016-7-15 20:11 | 只看該作者
回復 5# Michelle-W
請測試
資料-3.rar (27.11 KB)

TOP

Michelle-W

帖子
63 
主題
13 
精華
0 
積分
122 
點名
0  
作業系統
Windows 
軟體版本
office2007 
閱讀權限
20 
性別
女 
註冊時間
2015-4-22 
最後登錄
2019-7-19 
8#
發表於 2016-7-18 16:25 | 只看該作者
回復 6# c_c_lai


謝謝您的指導~ ^^
這組程式碼我看得比較吃力，比較難...
您有特別註明只針對5月份的資料
請問如果同時有5月與6月的資料要新增進去專屬工作表內，
就無法使用或修改這組程式碼的寫法對嗎??
我自己亂改，資料都會被覆蓋，只顯示6月的資料 QQ
如果可以的話，再麻煩您指點一下
感謝><"

TOP

c_c_lai

帖子
2035 
主題
24 
精華
0 
積分
2031 
點名
0  
作業系統
Win7 
軟體版本
Office2010 
閱讀權限
100 
性別
男 
註冊時間
2012-3-22 
最後登錄
2024-2-1 
9#
發表於 2016-7-18 20:33 | 只看該作者
回復 8# Michelle-W
請參考！





各自分類資料.rar (33.09 KB)

TOP

c_c_lai

帖子
2035 
主題
24 
精華
0 
積分
2031 
點名
0  
作業系統
Win7 
軟體版本
Office2010 
閱讀權限
100 
性別
男 
註冊時間
2012-3-22 
最後登錄
2024-2-1 
10#
發表於 2016-7-18 20:36 | 只看該作者
回復 8# Michelle-W
  1. Sub 各自分類()
  2.     Dim lg As Variant, ctn As Variant, xi As Boolean
  3.     Dim dic As Object, sp As Variant
  4.     Dim sh As Worksheet, wks As Worksheet
  5.    
  6.     Set sh = Worksheets("選單")
  7.     Set dic = CreateObject("scripting.dictionary")
  8.    
  9.     With sh
  10.         For Each lg In .Range("C1", .Range("C1").End(xlToRight))
  11.             .Select
  12.             
  13.             dic(lg.Value) = ""
  14.             For Each ctn In .Range("A2", Range("A2").End(xlDown))
  15.                 If ctn.Offset(, lg.Column - 1) = "V" Then
  16.                     dic(lg.Value) = dic(lg.Value) + IIf(dic(lg.Value) = "", "", ",") + ctn.Value
  17.                 End If
  18.             Next
  19.             If dic(lg.Value) <> "" Then
  20.                sp = Split(dic(lg.Value), ",")
  21.                 Cells(15, lg.Column).Resize(UBound(sp) + 1) = Application.Transpose(Array(sp))    '  展示用
  22.                
  23.                 xi = tblExist(lg.Value)      '  判斷表單是否存在
  24.                 If xi = False Then
  25.                     Sheets.Add After:=Sheets(Worksheets.Count)
  26.                     ActiveSheet.Name = lg.Value
  27.                 End If
  28.                
  29.                 With Worksheets(lg.Value)
  30.                     .Cells.Clear
  31.                     .[A1] = sh.[A1]
  32.                     .[B1] = lg.Value
  33.                     .[A2].Resize(UBound(sp) + 1) = Application.Transpose(Array(sp))
  34.                     .[B2].Resize(UBound(sp) + 1) = "V"
  35.                 End With
  36.             End If
  37.         Next
  38.     End With
  39. End Sub

  41. Sub 新增選單()
  42.     Dim rng As Range, rng2 As Range
  43.    
  44.     刪除工作表
  45.     With Worksheets("選單")
  46.         .Cells.Clear
  47.         Set rng = Sheets("總表").Range("A2", Sheets("總表").[A2].End(xlDown))
  48.         .[C1].Resize(, rng.Count - 1) = Application.Transpose(rng)
  49.         Set rng = Sheets("總表").Range("A16", Sheets("總表").[B16].End(xlDown))
  50.         rng.Copy .[A1]
  51.     End With
  52. End Sub

  54. Function tblExist(tblName As String) As Boolean
  55.     Dim xi As Integer
  56.    
  57.     tblExist = False
  58.     For xi = 1 To Worksheets.Count
  59.         If Worksheets(xi).Name = tblName Then tblExist = True: Exit Function
  60.     Next xi
  61. End Function

  63. Sub 刪除工作表()
  64.     Dim xi As Integer
  65.    
  66.     Application.DisplayAlerts = False
  67.     For xi = Worksheets.Count To 2 Step -1
  68.         If Worksheets(xi).Name <> "總表" And Worksheets(xi).Name <> "選單" Then
  69.             Worksheets(xi).Delete
  70.         End If
  71.     Next xi
  72.     Application.DisplayAlerts = True
  73. End Sub

  75. Sub 刪除各分頁()
  76.     刪除工作表
  77.     With Worksheets("選單")
  78.         .Range("C2:" & Chr(64 + .[C1].End(xlToRight).Column) & 65535).Clear
  79.     End With
  80. End Sub
複製代碼

TOP

        靜思自在 : 君子立恆志，小人恆立志。
12
返回列表 上一主題