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

帖子: 2035
主題: 24
精華: 0
積分: 2031
點名: 0
作業系統: Win7
軟體版本: Office2010
閱讀權限: 100
性別: 男
註冊時間: 2012-3-22
最後登錄: 2024-2-1

2^#

發表於 2016-7-14 19:15 | 只看該作者

回復 1# Michelle-W
試試看！

Sub Ex()
Dim lg As Variant, ctn As Variant, xi As Integer
Dim dic As Object, sp As Variant, sh As Worksheet
Set sh = Worksheets("05月")
Set dic = CreateObject("scripting.dictionary")
With sh
For Each lg In .Range("B1:I1")
.Select
dic(lg.Value) = ""
For Each ctn In .Range("A2:A7")
If ctn.Offset(, lg.Column - 1) = "V" Then
dic(lg.Value) = dic(lg.Value) + IIf(dic(lg.Value) = "", "", ",") + ctn.Value
End If
Next
sp = Split(dic(lg.Value), ",")
' Cells(15, lg.Column).Resize(UBound(sp) + 1) = Application.Transpose(Array(sp)) ' 展示用
For xi = 1 To Worksheets.Count
If Worksheets(xi).Name = lg.Value Then Worksheets(xi).Select: Exit For
Next xi
If xi > Worksheets.Count Then
Sheets.Add After:=Sheets(Worksheets.Count)
ActiveSheet.Name = lg.Value
End If
With Worksheets(lg.Value)
.[A1] = sh.[A1]
.[B1] = lg.Value
.[A2].Resize(UBound(sp) + 1) = Application.Transpose(Array(sp))
.[B2].Resize(UBound(sp) + 1) = "V"
End With
Next
End With
End Sub

複製代碼

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
這組程式碼太複雜了，我還看不懂>"<

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

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)

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)

帖子: 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)

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)

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
如果可以的話，再麻煩您指點一下
感謝><"

帖子: 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)

帖子: 2035
主題: 24
精華: 0
積分: 2031
點名: 0
作業系統: Win7
軟體版本: Office2010
閱讀權限: 100
性別: 男
註冊時間: 2012-3-22
最後登錄: 2024-2-1

10^#

發表於 2016-7-18 20:36 | 只看該作者

回復 8# Michelle-W

Sub 各自分類()
Dim lg As Variant, ctn As Variant, xi As Boolean
Dim dic As Object, sp As Variant
Dim sh As Worksheet, wks As Worksheet
Set sh = Worksheets("選單")
Set dic = CreateObject("scripting.dictionary")
With sh
For Each lg In .Range("C1", .Range("C1").End(xlToRight))
.Select
dic(lg.Value) = ""
For Each ctn In .Range("A2", Range("A2").End(xlDown))
If ctn.Offset(, lg.Column - 1) = "V" Then
dic(lg.Value) = dic(lg.Value) + IIf(dic(lg.Value) = "", "", ",") + ctn.Value
End If
Next
If dic(lg.Value) <> "" Then
sp = Split(dic(lg.Value), ",")
Cells(15, lg.Column).Resize(UBound(sp) + 1) = Application.Transpose(Array(sp)) ' 展示用
xi = tblExist(lg.Value) ' 判斷表單是否存在
If xi = False Then
Sheets.Add After:=Sheets(Worksheets.Count)
ActiveSheet.Name = lg.Value
End If
With Worksheets(lg.Value)
.Cells.Clear
.[A1] = sh.[A1]
.[B1] = lg.Value
.[A2].Resize(UBound(sp) + 1) = Application.Transpose(Array(sp))
.[B2].Resize(UBound(sp) + 1) = "V"
End With
End If
Next
End With
End Sub
Sub 新增選單()
Dim rng As Range, rng2 As Range
刪除工作表
With Worksheets("選單")
.Cells.Clear
Set rng = Sheets("總表").Range("A2", Sheets("總表").[A2].End(xlDown))
.[C1].Resize(, rng.Count - 1) = Application.Transpose(rng)
Set rng = Sheets("總表").Range("A16", Sheets("總表").[B16].End(xlDown))
rng.Copy .[A1]
End With
End Sub
Function tblExist(tblName As String) As Boolean
Dim xi As Integer
tblExist = False
For xi = 1 To Worksheets.Count
If Worksheets(xi).Name = tblName Then tblExist = True: Exit Function
Next xi
End Function
Sub 刪除工作表()
Dim xi As Integer
Application.DisplayAlerts = False
For xi = Worksheets.Count To 2 Step -1
If Worksheets(xi).Name <> "總表" And Worksheets(xi).Name <> "選單" Then
Worksheets(xi).Delete
End If
Next xi
Application.DisplayAlerts = True
End Sub
Sub 刪除各分頁()
刪除工作表
With Worksheets("選單")
.Range("C2:" & Chr(64 + .[C1].End(xlToRight).Column) & 65535).Clear
End With
End Sub

複製代碼