CODEWITHSUNDEEP
vbaexcel
TornHair
TornHair

Reputation: 55

VBA copy from a union of two ranges to a row of another range

Dear competent people.

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.

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.

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.

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.

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.

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

Upvotes: 2

Views: 1995

Answers (1)

assylias
assylias

Reputation: 328618

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

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

Upvotes: 1

Related Questions