Копирование VBA из объединения двух диапазонов в ряд другого диапазона

Question

Уважаемые компетентные люди.

У меня проблема со следующим кодом, особенно из-за того, что саб завершает правильно, но не копирует правильные данные в правильное местоположение.Я получаю повторяющийся узор из линий нулей, который не коррелирует с имеющимися итераторами.

Я думаю, что проблема заключается в копировании значений из подмножества диапазона, Episode & r.Ранее я смотрел на использование свойства union, но это было показано неправильно комментатором ниже.

В настоящее время я девять диапазонов с именем «Эпизод» 1-9, каждая строка которого содержит данные для одного респондента.Столбцы с 5 по 15 этих диапазонов содержат данные для копирования, поэтому диапазон, который нужно скопировать для каждого респондента: строка i, столбцы с пятого по пятнадцатый.Это шаг, с которым я застрял.

Если бы я мог скопировать его, данные оказались бы на листе 2, где для каждого респондента был назван диапазон, названный Респондент & n.Строки Response & n представляют временные интервалы, в течение которых может происходить Episode & r.За пределами слотов, где происходит Episode & r, могут быть нули, но это на самом деле не нужно.

Логическая структура, кажется, работает нормально.Я внимательно следил за локальными значениями счетчиков при отладке, и они работают так, как и положено.

В настоящее время я рассматриваю использование метода Range.Item для выбора строки 'n', столбцы 5-15 изЭпизод & r, но не могу понять его правильно.

Любая помощь будет очень признательна.

Ссылка на лист с примерами здесь: 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