返回列表 上一主題 發帖

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

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

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


再次感謝 :)
資料.rar (837.08 KB) 的)

回復 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

回復 2# c_c_lai


會出現1004的錯誤QQ
擷取.JPG
2016-7-14 20:59

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


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

TOP

回復 1# Michelle-W
請參考。
資料-1.rar (30.43 KB)

TOP

回復 4# Kubi


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

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

TOP

回復 3# Michelle-W
A0.png
2016-7-15 18:14

資料.rar (1.1 MB)

TOP

回復 5# Michelle-W
請測試
資料-3.rar (27.11 KB)

TOP

回復 6# c_c_lai


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

TOP

回復 8# Michelle-W
請參考!
E1.png
2016-7-18 20:31

E2.png
2016-7-18 20:31

E3.png
2016-7-18 20:32

E4.png
2016-7-18 20:32


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

TOP

回復 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

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

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

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

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

TOP

        靜思自在 : 一個缺口的杯子,如果換一個角度看它,它仍然是圓的。
返回列表 上一主題