ExcelのVBA自動化行全体をセル値に基づいて "X"回コピーして別のシートに貼り付けます

Question

VBAに比較的新しいです。私が実行した状況は、Xをコピーして貼り付ける必要がある私は以下のコードを使って別のシートにコピーするだけでうまくいきました。私が今実行している問題は、私が変更して列Aに数式があるので、それを少し動かすことです。ただし、コードは式をコピーしています。

私はpastespecialに関するもう少し研究をしましたが、以下の最初のコードと同じようにコードを取得して、列Aの式の値を貼り付けることしかできないようです。私は行全体をコピーすることには拘束されていませんが、列A-Yが必要です。どんな援助も大歓迎です！

Public Sub CopyData() 
' This routing will copy rows based on the quantity to a new sheet. 
Dim rngSinglecell As Range 
Dim rngQuantityCells As Range 
Dim intCount As Integer 

' Set this for the range where the Quantity column exists. This works only if there are no empty cells 
Set rngQuantityCells = Range("D1", Range("D1").End(xlDown)) 

For Each rngSinglecell In rngQuantityCells 
    ' Check if this cell actually contains a number 
    If IsNumeric(rngSinglecell.Value) Then 
     ' Check if the number is greater than 0 
     If rngSinglecell.Value > 0 Then 
      ' Copy this row as many times as .value 
      For intCount = 1 To rngSinglecell.Value 
       ' Copy the row into the next emtpy row in sheet2 
       Range(rngSinglecell.Address).EntireRow.Copy Destination:= Sheets("Sheet2").Range("A" & Rows.Count).End(xlUp).Offset(1)         
       ' The above line finds the next empty row. 

      Next 
     End If 
    End If 
Next 
End Sub 

も ​​- 私はしばらくの間、このフォーラムの周りに潜んでいましたし、あなたのすべては、あなたがここに偉大なリソース何をすべきかで素晴らしいです！最終的に参加してうれしいです。

Answer 1

以下のリファクタリングされたコードを試してください。これはあなたの目標を達成し、おそらくより高速に動作します。下の行は私に型の不一致エラーを与えている

Public Sub CopyData() 

' This routing will copy rows based on the quantity to a new sheet. 
Dim rngSinglecell As Range 
Dim rngQuantityCells As Range 
Dim intCount As Integer 

' Set this for the range where the Quantity column exists. This works only if there are no empty cells 
Set rngQuantityCells = Range("D1", Range("D1").End(xlDown)) 

For Each rngSinglecell In rngQuantityCells 

    ' Check if this cell actually contains a number and if the number is greater than 0 
    If IsNumeric(rngSinglecell.Value) And rngSingleCell.Value > 0 Then 

     ' Copy this row as many rows as .value and 25 columns (because A:Y is 25 columns) 
     Sheets("Sheet2").Range("A" & Rows.Count).End(xlUp).Offset(1).Resize(rngSinglecell.Value, 25).Value = _ 
      Range(Range("A" & rngSinglecell.Row), Range("Y" & rngSinglecell.Row)).Value 

    End If 
Next 

End Sub