VBA从两个范围的联合复制到另一个范围的行 [英] VBA copy from a union of two ranges to a row of another range

问题描述

亲爱的合格人士。

我在下列代码中遇到问题，具体来说，子代码正确完成，但不会将正确的数据复制到正确的位置。我得到一个与迭代器不相关的零行的重复模式。

I'm having a problem with the following code, specifically that the sub completes correctly but does not copy the correct data to the correct location. I get a repeating pattern of lines of zeros which does not correlate with the iterators in place.

我认为问题在于复制一个子集的值范围，剧集& r。以前我看过使用联盟财产，但下面的评论者显示是错误的。

I think the problem is with copying the values from a sub-set of a range, Episode&r. Previously I looked at using the union property but this was shown to be wrong by a commenter below.

目前，我的九个范围名为Episode1-9，其中每行包含一个受访者的数据。这些范围的第5至15列包含要复制的数据，因此每个受访者要复制的范围是：行i，列5至十五。这是我坚持的一步。

Currently I nine ranges named "Episode"1-9 each row of which contains data for one respondent. Columns 5 through 15 of these ranges contain the data to be copied, therefore the range to be copied for each respondent is: row i, columns five through fifteen. This is the step I an stuck with.

如果我可以复制它，数据将会结束于sheet2，其中为每个被调查者命名了一个范围，称为答辩人& ñ。响应& n行表示可以发生剧集& r的时隙。在发生剧集和插曲的插槽之外，可以有零个，但实际上并不是必需的。

If I could copy it, the data would end up on sheet2 where a range has been named for each respondent, called Respondent&n. The rows of Response&n represent time slots during which Episode&r can occur. Outside of slots where Episode&r occurs there can be zeroes, but this isn't actually necessary.

逻辑结构似乎工作正常。我已经在调试中仔细观察了本地计数器的值，他们按照原样工作。

The logical structure appears to work fine. I have watched the Local values for the counters closely in debugging and they work as they are supposed to.

我目前正在使用Range.Item方法来选择行'n'，第5-15列从Episode& r，但不能正确。

I am currently looking at using the Range.Item method to select row 'n', columns 5-15 from Episode&r, but cannot get it right.

任何帮助都将非常感谢。

Any assistance at all would be very much appreciated.

到示例表的链接在这里： http ：//dl.dropbox.com/u/41041934/StackOverflow/TornHairExampleSheet.xlsm

A link to an example sheet is here: 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

推荐答案

说实话，你的电子表格是一个真正的混乱，这也可能是为什么你觉得很难使用它！

To be honest, your spreadsheet is a real mess, which is also probably why you find it difficult to work with it!

无论如何，您尝试实现的内容似乎是：在名为episode1的范围内，您将要捕获与第i个受访者相对应的行号i，并将信息复制到第二张表。并为每一集和答辩人做。如果是这样，下面的代码似乎正在做你想要的。它不是很干净，可以进一步改善。

Anyway, what you are trying to achieve seems to be: in your range named episode1, you would like to capture the row number i which corresponds to your i-th respondent and copy the information to your second sheet. And do that for each episode and respondent. If that is the case, the code below seems to be doing what you want. It is not very clean and could be improved further.

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从两个范围的联合复制到另一个范围的行的文章就介绍到这了，希望我们推荐的答案对大家有所帮助，也希望大家多多支持IT屋！