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
4

1 回答 1

1

一些评论：

Sub PagesByDescription() 的上半部分读起来相当混乱，但可能有用……您可以非常自由地解释 With ... End With 括号的使用

第二个 With / Foreach 建议您要在工作表 wSheetStart 中工作，但此时 rRange 已经指向唯一列表，因为您在第一个 With 块内重新定义了它......不确定这是否是意图。

我建议您稍微清理一下代码，这将使您更清楚：

  • 使用缩进
  • 具体说明您的范围的父对象是什么......这几乎很清楚
  • 不要将 rRange 用于不同的目的，投资另一个变量名
于 2013-10-17T19:07:51.670 回答