刮掉数据并粘贴到单独的工作表的工作表

Question

此短脚本在“下一个”中断。我想将这些数据保存在一个集合中，这样我就可以转储和定制它在整个工作簿中的显示方式。感谢您的帮助

编辑：更新我的代码。仍然遇到问题。

资源类

'''''''''''''''''''''' 
' Name property 
'''''''''''''''''''''' 
Public Property Get Name() As String 
    Name = pName 
End Property 
Public Property Let Name(Value As String) 
    pName = Value 
End Property 

'''''''''''''''''''''' 
' City property 
'''''''''''''''''''''' 
Public Property Get City() As String 
    City = pCity 
End Property 
Public Property Let City(Value As String) 
    pCity = Value 
End Property 

'''''''''''''''''''''' 
' Title property 
'''''''''''''''''''''' 
Public Property Get Title() As String 
    Title = pTitle 
End Property 
Public Property Let Title(Value As String) 
    pTitle = Value 
End Property 

脚本

Sub searchResources() 


Dim a As Range 
Dim cell As Variant 
Dim Resources As Collection 
Dim Emp As Resource 
Dim Count As Integer 




For Each cell In a.Rows 
    If cell.Value = "Dallas" Or cell.Value = "Oklahoma City" Or cell.Value = "Houston" Then 
    Set Emp = New Resource 
     Emp.City = cell.Value 
     cell.Offset(0, -2).Select 
     Emp.Title = cell.Value 
     cell.Offset(0, -1).Select 
     Emp.Name = cell.Value 
      Resources.Add Emp 


        End If 

Resume Next 

For Each Emp In Resources 

ActiveWorkbook.Sheets("A").Activate 
a.Select 
    Debug.Print Emp.Name 
    Debug.Print Emp.City 
    Debug.Print Emp.Title 
Next Emp 

End Sub 

Answer 1

For Each cell In a.Rows 
    If cell.Value = "Dallas" Then 
    Set Emp = New Resource 
     Emp.City = cell.Value 
     cell.Offset(0, -2).Select 
     Emp.Title = cell.Value 
     cell.Offset(0, -1).Select 
     Emp.Name = cell.Value 
      Resources.Add Emp 

      >> Resume Next 

    ElseIf cell.Value = "Oklahoma City" Then 
    Set Emp = New Resource 
     Emp.City = cell.Value 
     cell.Offset(0, -2).Select 
     Emp.Title = cell.Value 
     cell.Offset(0, -1).Select 
     Emp.Name = cell.Value 
      Resources.Add Emp 

      >> Resume Next 

    ElseIf cell.Value = "Houston" Then 
    Set Emp = New Resource 
     Emp.City = cell.Value 
     cell.Offset(0, -2).Select 
     Emp.Title = cell.Value 
     cell.Offset(0, -1).Select 
     Emp.Name = cell.Value 
      Resources.Add Emp 

     >> Resume Next 

      End If 
>>> Next 

For Each Emp In Resources 

ActiveWorkbook.Sheets("A").Activate 
a.Select 
    Debug.Print Emp.Name 
    Debug.Print Emp.City 
    Debug.Print Emp.Title 
Next Emp 

End If <<<Why here have end if? i think you should delete it, cause it doesnt have IF stand for it 


UPDATE 

我觉得你的剧本得到了太长时间，而不是需要在同一

For Each cell In a.Rows 
    If cell.Value = "Dallas" or cell.Value = "Oklahoma City" or cell.Value = "Houston" Then 
    Set Emp = New Resource 
     Emp.City = cell.Value 
     cell.Offset(0, -2).Select 
     Emp.Title = cell.Value 
     cell.Offset(0, -1).Select 
     Emp.Name = cell.Value 
      Resources.Add Emp 
        End If 
else 
'based on you want to EXIT FOR or RESUME NEXT 
Next 

For Each Emp In Resources 

ActiveWorkbook.Sheets("A").Activate 
a.Select 
    Debug.Print Emp.Name 
    Debug.Print Emp.City 
    Debug.Print Emp.Title 
Next Emp 

Answer 2

它看起来像重复你使用Resume Next，你应该使用Next cell波纹请参阅纠正代码：

Sub searchResources() 


Dim a As Range 
Dim cell As Variant 
Dim Resources As Collection 
Dim Emp As Resource 
Dim Count As Integer 




For Each cell In a.Rows 
    If cell.Value = "Dallas" Or cell.Value = "Oklahoma City" Or cell.Value = "Houston" Then 
    Set Emp = New Resource 
     Emp.City = cell.Value 
     cell.Offset(0, -2).Select 
     Emp.Title = cell.Value 
     cell.Offset(0, -1).Select 
     Emp.Name = cell.Value 
      Resources.Add Emp 


        End If 

Next cell 

For Each Emp In Resources 

ActiveWorkbook.Sheets("A").Activate 
a.Select 
    Debug.Print Emp.Name 
    Debug.Print Emp.City 
    Debug.Print Emp.Title 
Next Emp 

End Sub 

Answer 3

运行你的代码虽然是美化给了我一个提示：没有Next cell对应For Each cell In a.Rows

的美化可以发现here。 （该网站只显示了到Office 2003，但我已经在2007年和2010年进行了测试，它完美的作品）美化后

由此得到的代码：

Sub searchResources() 

Dim a As Range 
Dim cell As Variant 
Dim Resources As Collection 
Dim Emp As Resource 
Dim Count As Integer 

For Each cell In a.Rows 
    If cell.Value = "Dallas" Or cell.Value = "Oklahoma City" Or cell.Value = "Houston" Then 
     Set Emp = New Resource 
     Emp.City = cell.Value 
     cell.Offset(0, -2).Select 
     Emp.Title = cell.Value 
     cell.Offset(0, -1).Select 
     Emp.Name = cell.Value 
     Resources.Add Emp 


    End If 

    Resume Next 

    For Each Emp In Resources 

     ActiveWorkbook.Sheets("A").Activate 
     a.Select 
Debug.Print Emp.Name 
Debug.Print Emp.City 
Debug.Print Emp.Title 
    Next Emp 

    End Sub 

公告称，End Sub也不行了与Sub()声明

Answer 4

我修改了类略（由私有变量，并纠正了PROC。在proc我用“选定的单元格”作为我的范围变量，我不知道你打算如何传递。我还创建了一个新工作表，并添加了一小段代码以确保我们给出的工作表名称t是独一无二的。

的类别：

Private pName As String 
Private pCity As String 
Private pTitle As String 

'''''''''''''''''''''' 
' Name property 
'''''''''''''''''''''' 
Public Property Get Name() As String 
    Name = pName 
End Property 
Public Property Let Name(Value As String) 
    pName = Value 
End Property 

'''''''''''''''''''''' 
' City property 
'''''''''''''''''''''' 
Public Property Get City() As String 
    City = pCity 
End Property 
Public Property Let City(Value As String) 
    pCity = Value 
End Property 

'''''''''''''''''''''' 
' Title property 
'''''''''''''''''''''' 
Public Property Get Title() As String 
    Title = pTitle 
End Property 
Public Property Let Title(Value As String) 
    pTitle = Value 
End Property 

，并且过程：

Sub searchResources() 
Dim a As Range 
Dim cell As Range 'As Variant (This is a range) 
Dim Resources As Collection 
Dim Emp As Resource 
Dim Count As Integer 
'--------- 
Dim oWS As Worksheet 
Dim iRow As Integer, iTest As Integer 
Set Resources = New Collection 

'Setting the range to selected range on active sheet for my tests 
'Assign your range as you see fit 
Set a = Application.Selection 


For Each cell In a.Cells 
    If cell.Value = "Dallas" Or cell.Value = "Oklahoma City" Or cell.Value = "Houston" Then 
    Set Emp = New Resource 

     Emp.City = cell.Value 
     Emp.Title = cell.Offset(0, -2).Value 
     Emp.Name = cell.Offset(0, -1).Value 
     Resources.Add Emp 
    End If 
Next cell 

Set oWS = Worksheets.Add(After:=Worksheets(Worksheets.Count)) 

'create a unique name 
iRow = 1 
On Error Resume Next 'Turn on error handling 
iTest = Len(Worksheets("Resources").Name) 
'check for error 
If Err.Number <> 0 Then 'Sheet doesn't exist 
    oWS.Name = "Resources" 
Else 
    Do 
     iTest = Len(Worksheets("Resources" & iRow).Name) 
     If Err.Number <> 0 Then 
      oWS.Name = "Resources" & iRow 
      Exit Do 
     Else 
      iRow = iRow + 1 
     End If 
     DoEvents 'Allows CTRL-BREAK to break execution during the cycle 
    Loop 
End If 
On Error GoTo 0 'Turn off error handling 
iRow = 2 
oWS.Range("A1").Value = "Name" 
oWS.Range("B1").Value = "Title" 
oWS.Range("C1").Value = "City" 

For Each Emp In Resources 
    oWS.Range("A" & iRow) = Emp.Name 
    oWS.Range("C" & iRow) = Emp.City 
    oWS.Range("B" & iRow) = Emp.Title 
    iRow = iRow + 1 
Next Emp 

End Sub