Question

亲爱的有能力的人。

我遇到以下代码的问题，特别是sub正确完成但没有将正确的数据复制到正确的位置。我得到一个重复的零行模式，它与迭代器没有关联。

我认为问题在于从一个范围的子集Episode＆amp; r中复制值。以前我看过使用union属性，但下面的评论者证明这是错误的。

目前，我的九个范围名为“Episode”1-9，每行包含一个受访者的数据。这些范围的第5列到第15列包含要复制的数据，因此每个响应者要复制的范围是：第i行，第5列到第15列。这是我坚持的步骤。

如果我可以复制它，数据将最终出现在sheet2上，其中为每个受访者命名了一个名为Respondent＆amp; n的范围。 Response＆amp; n行表示可以发生Episode＆amp; r的时隙。在Episode＆amp; r出现的插槽之外，可以有零，但这实际上并不是必需的。

逻辑结构似乎工作正常。我在调试中仔细观察了计数器的Local值，它们按预期工作。

我目前正在使用Range.Item方法从Episode＆amp; r中选择行'n'，第5-15行，但无法正确使用。

非常感谢任何协助。

示例表的链接位于：http://dl.dropbox.com/u/41041934/StackOverflow/TornHairExampleSheet.xlsm

Sub PopulateMedia()
Application.ScreenUpdating = False
Sheets(1).Activate

'Count the total number of response rows in original sheet
Dim Responses As Long, n As Integer, i As Integer, j As Integer, r As Integer
Responses = Sheets("Sheet1").Range("A:A").End(xlDown).row

'For each response...
For n = 1 To Responses
Dim curr_resp As Range
Set curr_resp = Sheets(2).Range("Response" & n) 'Define a range containing all response data
    For r = 1 To 9 'For each episode...
        Dim curr_ep As Range 'Define a range containing episode data for all responses
        Set curr_ep = Sheets(1).Range("episode" & r)

'Variables contain start, end and inter-episode times
        Dim Stime As Integer, Etime As Integer, Itime As Integer 
    Stime = curr_ep.Cells(n, 1).Value
    Etime = curr_ep.Cells(n, 16).Value
    Itime = curr_ep.Cells(n, 18).Value

'Define a range within this episode which contains the columns to be copied
 Dim media As Range 
    Sheets(1).Activate
    Set media = Set media = Sheets(1).Range("Episode" & r).Item(n, "5:15") 'range to be copied is union of active episode and active response.***This line is certainly incorrect, example purpose.

    Sheets(2).Activate

'for each time-slot...***This is the section I'm having trouble with
        For i = 1 To (Etime + Itime) 
            If i > Etime Then
'fill the response range with zeros for time slots outside Stime and Etime
            Sheets(2).Range("Response" & n).Rows = 0 
            ElseIf i >= Stime Then
'Copy data from above union for slots between Stime and Etime
            Sheets(2).Range("Response" & n).Rows(i) = media 
            Else
'Stick with the zeroes until a new 'r' means a new episode***
            Sheets(2).Range("Response" & n).Rows(i) = 0 
            End If
        Next i
    Next r
Next n
End Sub

Answer 1

说实话，你的电子表格真是乱七八糟，这也可能是你难以使用它的原因！

无论如何，你想要实现的目标似乎是：在你名为episode1的范围内，你想要捕获对应于你的第i个受访者的行号i并将信息复制到你的第二张表。并为每一集和受访者做到这一点。如果是这种情况，下面的代码似乎正在做你想要的。它不是很干净，可以进一步改进。

Sub PopulateMedia()
    Application.ScreenUpdating = False

    'Count the total number of response rows in original sheet
    Dim Responses As Long, n As Integer, i As Integer, j As Integer, r As Integer
    Responses = Sheets("Sheet1").Range("A:A").End(xlDown).Row

    'For each response...
    For n = 1 To Responses
        Dim curr_resp As Range
        Set curr_resp = Sheets(2).Range("Response" & n) 'Define a range containing all response data
        For r = 1 To 9 'For each episode...
            Dim curr_ep As Range 'Define a range containing episode data for all responses
            Set curr_ep = Sheets(1).Range("episode" & r)
            Dim Stime As Integer, Etime As Integer, Itime As Integer 'Variables contain start, end and inter-episode times
            Stime = curr_ep.Cells(n, 1)
            Etime = curr_ep.Cells(n, 16)
            Itime = curr_ep.Cells(n, 18)
            Dim media As Range 'Define a range within this episode which contains the columns to be copied
            Set media = Sheets(1).Range("Episode" & r)
            For i = 1 To (Etime + Itime) 'for each time-slot...***This is the section I'm having trouble with
                If i > Etime Then
                  curr_resp.Rows(i) = 0 'fill the response range with zeros for time slots outside Stime and Etime
                ElseIf i >= Stime Then
                  Dim a As Variant
                  a = media.Range(media.Cells(n, 5), media.Cells(n, 15))
                  curr_resp.Rows(i).Resize(1, 11) = a 'Copy data from above union for slots between Stime and Etime
                Else
                  curr_resp.Rows(i) = 0 'Stick with the zeroes until a new 'r' means a new episode***
                End If
            Next i
        Next r
    Next n

    Application.ScreenUpdating = True
End Sub

VBA从两个范围的并集复制到另一个范围的一行

1 个答案: