0
這是我從其他人的帖子和建議中收集的當前代碼，並對其進行了修改以適合我的需要。根據列表中的值運行宏
「的代碼做
什麼它目前在表中讀取值，過濾值，以獨特的列表，它需要的值，並創建了一個名爲唯一列表與列表中的這些值表。根據該列表，它爲表中列出的每個唯一值創建一個表。
「問題
此代碼的偉大工程，到目前爲止，但現在我需要添加基於送行的獨特價值的信息。下面我把註釋（'>我想插入新的程序在這裏）到我想要把新的程序（這將從原始數據表中添加數據）。以下是我想要添加的程序。但是當我運行它時，它會創建比應該更多的選項卡，然後關閉我的Excel。期望的結果是爲了使用唯一值轉到原始表格，根據每個唯一值過濾表格並複製特定列中的所有信息，然後將其粘貼回與剛纔創建的表格相關的表格中之前爲那個具體的價值。
我真的認爲它的事實，我在測試過程中的rCell，它不喜歡這樣。我知道如何到達「原始數據」表並複製信息，但我不知道如何返回到上一張表。我只是根據它的名稱調出該表，但我需要它作爲循環並運行該列表中的每個唯一值。
任何幫助，將不勝感激。我知道它很多要閱讀。我只是想給你們提供儘可能多的信息來幫助你理解我的項目。
'this is the code i want to insert into my 'Pagesbydescription' macro
'test start
Sheets("Raw Data").Select
Selection.AutoFilter
ActiveSheet.ListObjects("Table3").Range.AutoFilter Field:=11, Criteria1:= _
rCell
Range("A3:J5000").Select
Selection.Copy
Sheets.Select
Range("A3").Select
ActiveSheet.Paste
Columns("A:K").EntireColumn.AutoFit
'test end
Sub PagesByDescription()
'
'PagesByDescription
'
Dim rRange As Range, rCell As Range
Dim wSheet As Worksheet
Dim wSheetStart As Worksheet
Dim strText As String
Set wSheetStart = ActiveSheet
wSheetStart.AutoFilterMode = False
'Set a range variable to the correct item column
Set rRange = Range("K4", Range("K5000").End(xlUp))
'Delete any sheet called "UniqueList"
'Turn off run time errors & delete alert
On Error Resume Next
Application.DisplayAlerts = False
Worksheets("UniqueList").Delete
'Add a sheet called "UniqueList"
Worksheets.Add().Name = "UniqueList"
'Filter the Set range so only a unique list is created
With Worksheets("UniqueList")
rRange.AdvancedFilter xlFilterCopy, , _
Worksheets("UniqueList").Range("A1"), True
'Set a range variable to the unique list, less the heading.
Set rRange = .Range("A1", .Range("A5000").End(xlUp))
End With
On Error Resume Next
With wSheetStart
For Each rCell In rRange
strText = rCell
.Range("k1").AutoFilter 1, strText
Worksheets(strText).Delete
'Add a sheet named as content of rCell
Worksheets.Add().Name = strText
'> I would like to Insert new procedure here
Next rCell
End With
With wSheetStart
.AutoFilterMode = False
.Activate
End With
On Error GoTo 0
Application.DisplayAlerts = True
Application.DisplayAlerts = False
Sheets("NA").Delete
Sheets("BODY").Delete
Sheets("BODY PREBUILD").Delete
Application.DisplayAlerts = True