条件に基づいて1つのシートから別のブックに値をコピー

Question

私は、リストの各項目に行番号に基づくコードを割り当てるコードを書いています。私がそこからやりたいことは、選択したコードに対応する各行のすべての情報をコピーして別のブックに貼り付けることです。私はいくつかの問題を抱えてきた。ここでは、コードです：私は問題

wbLSHP.Activate 
For Each cell In CodeRange 
    If cell = "1" Then 
     Range(ActiveCell.Offset(0, -5), ActiveCell.Offset(0, 20)).Select 
     Selection.Copy 
     wbTEST.Sheets("Sheet1").Cells(PasteRow, 1).PasteSpecial xlPasteValues 
     PasteRow = PasteRow + 1 
    Else 
    End If 
Next cell 

End Sub 

最初の問題は、Forループ「CodeRange」に正しい範囲をコピーしていないさを抱えている場合について

Sub LSHP_Distribute() 

Dim wbLSHP As Workbook 
Dim wsLSHP As Worksheet 
Dim CodeRange As Range 
Dim FirstRow As Long 
Dim LastRow As Long 

Dim wbTEST As Workbook 

Set wbLSHP = ActiveWorkbook 
Set wsLSHP = wbLSHP.Sheets("Sheet1") 

'Generate codes for newly added items 
Application.ScreenUpdating = False            
'Turn off screen updating 

With wsLSHP 
    FirstRow = .Range("F3").End(xlDown).Row + 1 
    LastRow = .Range("B6", .Range("B6").End(xlDown)).Rows.Count + 5 
    Set CodeRange = .Range("$F$" & FirstRow, "$F$" & LastRow) 
End With 

For Each cell In CodeRange 
    If cell = "" Then 
     If cell.Row Mod 3 = 0 Then 
      cell.Value = "1" 
     ElseIf cell.Row Mod 3 = 1 Then 
      cell.Value = "2" 
     ElseIf cell.Row Mod 3 = 2 Then 
      cell.Value = "3" 
     Else 
     End If 
    End If 
Next cell 

'Open Spreadsheets to Distribute Items 
Dim PasteRow As Long 
Dim i As Integer 
Set wbTEST = Workbooks.Open(Filename:="V:\Test.xlsx") 

PasteRow = wbTEST.Sheets("Sheet1").Range("B6").End(xlDown).Row + 1 

がされ、第二の問題は、それをありますオートメーションエラーが発生する前に一度だけコピーします。ご質問がある場合はお知らせください。また、このコードを書くより効率的な方法をご存じですか？

ありがとうございました！

Answer 1

範囲は、開始がF3で、終了がBSomethingであると定義されていますが、CodeRangeにはF列だけが格納されます。

Set CodeRange = .Range("$F$" & FirstRow, "$F$" & LastRow) 

使用してみてください：

Set CodeRange = .Range("$B$" & FirstRow, "$F$" & LastRow) 

私はお勧めの代わりに、コピーして、貼り付け変数に値を代入し、wbTESTに変数の値を入れます。