特定のブックを別のブックにコピーする

Question

vbaで特定の行をコピーできません。ここで

私のコード：だから

Dim color1 As Integer 
Dim color2 As Integer 
Dim lines As Integer 

Workbooks.Open Filename:="D:\01 January.xlsm", _ 
    UpdateLinks:=0 
lines = WorksheetFunction.CountA(Range("U:U")) - 1 


Dim i As Integer 
For i = 6 To lines + 6 

color1 = Cells(i, 21).Value 
color2 = Cells(i, 22).Value 

    If IsNumeric(Cells(i, 21)) Then 

     Select Case color1 & color2 
      Case Evaluate("=White") & Evaluate("=Blue") 
       Rows(i & ":" & i).Select 

      Case Evaluate("=Yellow") & Evaluate("=Yellow") 
       Rows(i & ":" & i).Select 

      Case Evaluate("=Yellow") & Evaluate("=Green") 
       Rows(i & ":" & i).Select 

     End Select 

    End If 
Next i 

    Selection.Copy 

    Windows("Test.xlsm").Activate 

    Rows("11:11").Select 

    Selection.PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, _ 
     SkipBlanks:=False, Transpose:=False 
    Selection.PasteSpecial Paste:=xlPasteFormulas, Operation:=xlNone, _ 
     SkipBlanks:=False, Transpose:=False 

End Sub 

あなたが見るかもしれないとして、私はJanuary.xlsmで基準を満たす行を選択してtest.xlsm

に後から貼り付けしようとしています現時点では、最後に選択された行のみをペーストしますが、すべてをペーストしません。

私はvbaにはかなり新しいので、本当にあなたの助けが必要です。私が気にしていることは、必要な行をすべて配列に入れて、それを他のワークブックにコピーすることです。しかし、それが良いかちょうどrubishかどうか、それがうまくいくかどうか、私は解決策を見つけることができません...

あなたの助けをありがとう！

Answer 1

最後の行だけを貼り付ける理由は、個々の行を選択してループしているのに何もしないためです。修正されたコードを参照してください。 caseステートメントで冗長な選択を削除し、範囲/結合コンボを提供してカスタム範囲を作成し、ワークシートに一度だけ貼り付けるようにしました。

Dim color1 As Integer 
Dim color2 As Integer 
Dim lines As Integer 

Workbooks.Open Filename:="D:\01 January.xlsm", _ 
    UpdateLinks:=0 
lines = WorksheetFunction.CountA(Range("U:U")) - 1 


Dim i As Integer 
Dim rngUnion As Range 
Dim booCopy As Boolean 
For i = 6 To lines + 6 
    booCopy = True 
    color1 = Cells(i, 21).Value 
    color2 = Cells(i, 22).Value 

    If IsNumeric(Cells(i, 21)) Then 

     Select Case color1 & color2 
      Case Evaluate("=White") & Evaluate("=Blue") 
      Case Evaluate("=Yellow") & Evaluate("=Yellow") 
      Case Evaluate("=Yellow") & Evaluate("=Green") 
      Case Else 
       booCopy = False 
     End Select 

    End If 
    If booCopy = True Then 
     If rngUnion Is Nothing Then 
      Set rngUnion = Rows(i & ":" & i) 
     Else 
      Set rngUnion = Union(rngUnion, Rows(i & ":" & i)) 
     End If 
    End If 

Next i 
If Not rngUnion Is Nothing Then 
    rngUnion.Copy 
    Windows("Test.xlsm").Activate 
    With Rows("11:11") 
     .PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, _ 
      SkipBlanks:=False, Transpose:=False 
     .PasteSpecial Paste:=xlPasteFormulas, Operation:=xlNone, _ 
      SkipBlanks:=False, Transpose:=False 
    End With 
    Application.CutCopyMode = False 
End If 
End Sub 

Answer 2

これは、最後に選択した行を貼り付ける理由は、ループ内でコピーして貼り付けていないためです。ループ内でSelection.Copy/Pasteを移動すると、コードが機能するはずです。これを行うより良い方法は、完全にコピーして貼り付けたり、行の値を直接設定することを避けることです。

Dim i As Integer 
For i = 6 To lines + 6 

color1 = Cells(i, 21).Value 
color2 = Cells(i, 22).Value 

    If IsNumeric(Cells(i, 21)) Then 

     Select Case color1 & color2 
      Case Evaluate("=White") & Evaluate("=Blue"): 
       Workbooks("Test").Sheets("Sheet1").Rows(i).Value = _ 
        Workbooks("01 January").Sheets("Sheet1").Rows(i).Value 
      ... 
    End Select 

End If 
Next i 

必要に応じてシート名またはブック名を更新することができますが、この方法はコピーして貼り付けるよりも大幅に高速です。

Answer 3

は、あなたが行の大数をコピーする必要があり、それはどちらもUnion()もAddress()方法に依存しており、最初のコピーの行をマークする「ヘルパー」欄に切り替え、その後、コピーすることはないほうが安全です貼り付ける必要がありますし、ワンショットでペーストしてください。これはまた、唯一の「数値」細胞をフィルタリングするSpecialCells()方法を利用することができ、また

上記2つの方法その後、はるかに高速です：

Dim lines As Long 
Dim cell As Range 

Workbooks.Open Filename:="D:\01 January.xlsm", UpdateLinks:=0 
lines = WorksheetFunction.CountA(Range("U:U")) - 1 
With Range(Cells(6, "U"), Cells(lines + 6, "U")) '<--| reference your relevant range in column "U" 
    For Each cell In .SpecialCells(xlCellTypeConstants, xlNumbers) '<--| loop through "numeric" cells only 
     Select Case cell.Value & cell.Offset(, 1).Value 
      Case Evaluate("=White") & Evaluate("=Blue"), Evaluate("=Yellow") & Evaluate("=Yellow"), Evaluate("=Yellow") & Evaluate("=Green") 
       cell.Offset(, 2).Value = 1 '<--| mark row for copying&pasting 
     End Select 
    Next 
    With .Offset(, 2) '<-- consider column "W" cells corresponding to referenced cells 
     If WorksheetFunction.CountA(.Cells) > 0 Then '<--| if there's at least one row marked for copy&paste 
      .SpecialCells(xlCellTypeConstants, xlNumbers).EntireRow.Copy '<--| copy all marked rows 
      With Workbooks("Test.xlsm").ActiveSheet.Rows("11:11") '<--| reference target range 
       .PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, _ 
           SkipBlanks:=False, Transpose:=False 
       .PasteSpecial Paste:=xlPasteFormulas, Operation:=xlNone, _ 
           SkipBlanks:=False, Transpose:=False 
      End With 
      Application.CutCopyMode = False '<--| clear clipboard 
     End If 
     .ClearContents '<--| clear "helper" column 
    End With 
End With