为什么我的收藏是空白的?

时间:2013-04-15 19:27:34

标签: excel vba

这是一个VBA脚本。我不确定为什么我的收藏品没有填充“按市场”表格。

Sub ArrayPractice()

Dim r As Integer
Dim i As Integer
Dim a As Integer
Dim numberOfRows As Integer
Dim names() As String
Dim resourceCollect As Collection

Dim Emp As Resource
Dim Count As Long

Set resourceCollect = New Collection

a = Worksheets("DATA").Range("A:A").Cells.SpecialCells(xlCellTypeConstants).Count
r = 2 'row that i start looping from
i = 0

For Each Emp In resourceCollect

For Count = 0 To a
Emp.Name = Cells(r, 1).Value
Emp.Title = Cells(r, 2).Value
Emp.City = Cells(r, 3).Value
resourceCollect.Add Emp
r = r + 1
Next Count
Next Emp

''''print the array!''''

Sheets.Add.Name = "By Market"
Sheets.Add.Name = "By Resource Level"
Sheets.Add.Name = "By Resource Manager"



Sheets("By Market").Select
Range("C36").Select
r = 36
For Each Emp In resourceCollect
If Emp.City = "Dallas" Then
Cells(r, 3).Select
Debug.Print Emp.Name
r = r - 1
End If
Next Emp

Range("D36:D36").Select
r = 36
For Each Emp In resourceCollect
If Emp.City = "Denver" Then
Cells(r, 4).Select
Debug.Print Emp.Name
r = r - 1
End If
Next Emp

Range("E36:E36").Select
r = 36
For Each Emp In resourceCollect
If Emp.City = "Houston" Then
Cells(r, 5).Select
Debug.Print Emp.Name
r = r - 1
End If
Next Emp

Range("F36:F36").Select
r = 36
For Each Emp In resourceCollect
If Emp.City = "Kansas City (Missouri)" Then
Cells(r, 6).Select
Debug.Print Emp.Name
r = r - 1
End If
Next Emp

End Sub

更新

按照约瑟夫的回答,这是我尝试过的。我还没有工作。

这里有一些不同的我一直在搞乱。他们都在努力解决同样的问题。

Sub stackResources()

Dim c As New Collection

Dim r1 As Excel.Range 'an object
Dim r2 As Excel.Range
Dim r3 As Excel.Range


Set r1 = Range("A1")
Set r2 = Range("B1")
Set r3 = Range("C1")

c.Add r1
c.Add r2
c.Add r3

Sheets("By Market").Select
Range("A1").Select

Dim i As Long
For i = 1 To c.Count
    Debug.Print c.Item(i)
    Next


End Sub

Sub collectionTest()
Dim c As New Collection

Dim emp As Resource


Sheets("DATA").Select

Range("A1").Select

Do Until Selection.Value = ""
    emp.name = Selection.Value
        ActiveCell.Offset(0, 1).Select
    emp.Title = Selection.Value
        ActiveCell.Offset(0, 1).Select
    emp.city = Selection.Value
        c.Add emp

    Loop


Sheets("By Market").Select
Range("A1").Select

Dim i As Long
For i = 1 To c.Count
    Debug.Print c.Item(i)
    Next




End Sub

Sub printACollection()

Dim c As New Collection

Dim s1 As String
Dim s2 As String
Dim s3 As String

Sheets("DATA").Select

Dim r As Long


r = 1
For Each cell In Range("A1")
    s1 = cell.Value
    c.Add s1
    ActiveCell.Offset(0, 1).Select
    s2 = cell.Value
    c.Add s2
    ActiveCell.Offset(0, 1).Select
    s3 = cell.Value
    c.Add s3
    Next


    Sheets("By Market").Select

      Dim i As Long

    For i = 1 To c.Count
        Debug.Print c.Item(i)
    Next



End Sub

2 个答案:

答案 0 :(得分:2)

正在发生的事情是resourceCollect中没有任何内容,所以实际上你并没有循环任何东西。您必须向集合中添加项目才能循环使用它。

这是一个可能有用的基础教程:

http://www.wiseowl.co.uk/blog/s239/collections.htm

编辑:回答你的评论:

Public Sub test()
    Dim c As New Collection

    Dim s1 As String
    Dim s2 As String
    Dim s3 As String

    s1 = "hello"
    s2 = ","
    s3 = "world"

    c.Add s1
    c.Add s2
    c.Add s3

    Dim s As String

    For Each s In c
        Debug.Print s
    Next
End Sub

这将失败,因为您无法循环使用String数据类型...因为它只是一种数据类型而不是对象。在这种情况下,您必须遍历索引(索引?):

    Dim i As Long

    For i = 1 To c.Count
        Debug.Print c.Item(i)
    Next

但是,如果您使用VBA已知的对象,例如Range:

Public Sub test2()
    Dim c As New Collection

    Dim r1 As Excel.Range ' an object
    Dim r2 As Excel.Range

    Set r1 = Range("A1")
    Set r2 = Range("A3")

    c.Add r1
    c.Add r2

    Dim r As Excel.Range
    For Each r In c
        Debug.Print r.Address
    Next r
End Sub

这样可以正常使用。

如果您正在使用自定义类,则可以像使用Range对象一样使用对象循环访问集合。我引用的链接解释了可能存在的问题以及创建自己的Collection对象的解决方案。

答案 1 :(得分:1)

根据您的评论,这是另一个答案。我想这就是你要找的东西。如果没有,请更具描述性并修改您的问题。

您有一个名为Employee的类模块,其代码为:

Option Explicit

Public Name As String
Public City As String
Public Title As String

然后,在常规模块中,您可以使用下面的内容。密切关注示例并根据您的需要进行修改。我把Sort代码留了下来,所以你可以自己试一试。另外,请注意我如何将工作拆分为单独的函数/ subs。这可以使您的代码保持清洁,更易于遵循。希望这会有所帮助。

Option Explicit

Public Sub main()
    Application.ScreenUpdating = False

    Dim c As Collection
    Dim newWs As Excel.Worksheet
    Dim rData As Excel.Range

    Set rData = ThisWorkbook.Sheets("Sheet1").Range("A2:C3")

    Set c = getData(rData)
    Set newWs = ThisWorkbook.Worksheets.Add

    newWs.Name = "New report"

    Call putCollectionInWorksheet(newWs, c)

    Call sortData(newWs)

    Application.ScreenUpdating = True
End Sub

Private Function getData(ByRef rng As Excel.Range) As Collection
    ' create new collection of data
    Dim c As New Collection
    Dim i As Long
    Dim e As Employee
    For i = 1 To rng.Rows.Count
        Set e = New Employee

        e.Name = rng.Cells(i, 1) ' name column
        e.Title = rng.Cells(i, 2) ' title column
        e.City = rng.Cells(i, 3) ' city column

        c.Add e
    Next i

    Set getData = c
End Function

Private Sub putCollectionInWorksheet(ByRef ws As Excel.Worksheet, ByRef cData As Collection)
    Dim i As Long, j As Long
    Dim emp As Employee

    ' create header info
    ws.Range("A1:C1") = Array("Name", "Title", "City")
    i = 2 ' current row

    For Each emp In cData
        ws.Cells(i, 1).Value = emp.Name
        ws.Cells(i, 2).Value = emp.Title
        ws.Cells(i, 3).Value = emp.City

        i = i + 1
    Next emp
End Sub

Private Sub sortData(ByRef ws As Excel.Worksheet)
    ' code here
End Sub