2つの範囲の結合から別の範囲の行へのVBAコピー

Question

親愛なる有能な人。

次のコードに問題があります。具体的には、サブが正しく完了しても、正しいデータが正しい場所にコピーされません。イテレータとの位置関係にないゼロの線の繰り返しパターンが得られます。

私は問題は、範囲のサブセット、エピソード&rから値をコピーすることだと思います。以前はunionプロパティを使用していましたが、これは以下のコメント者によって間違っていることが示されていました。

現在、1つの回答者のデータが各行に含まれている「エピソード」1-9という9つの範囲があります。これらの範囲の列5〜15にはコピーするデータが含まれているため、回答者ごとにコピーされる範囲は行i、列5〜15です。これは私が立ち往生した一歩です。

もし私がそれをコピーすることができれば、データはシート2上に終わり、被回答者の名前は、回答者&となります。応答&nの行は、エピソード&rが発生することができるタイムスロットを表す。エピソード&rが発生するスロットの外側にはゼロが存在する可能性がありますが、これは実際には必要ありません。

論理構造が正常に動作しているようです。私はカウンターのローカル値をデバッグに密接に見てきました。

現在、Range.Itemメソッドを使用して、行「n」を選択しています。エピソード& rから列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を取得し、その情報を2番目のシートにコピーしたいと考えています。そして、各エピソードと回答者のためにそれを行います。その場合、以下のコードはあなたが望むことをしているようです。非常に清潔ではなく、さらに改善することができます。

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