範囲を単一の列にコピー - 値のみ

Question

こんにちは私は範囲を単一の列にコピーしようとしています。範囲は空白のセルと値のセルが混在しています。値をコピーして貼り付けたいだけで、最初の空白のセルを見つけてそこから列の下を歩きたいと思います。

私は今、（永遠にとっている）ペーストを最初の行に入れています。

Dim i As Integer 
i = 1 

ThisWorkbook.Worksheets("amount date").Select 
For Row = 51 To 100 
    For col = 2 To 1000 
     If Cells(Row, col).Value <> "" Then 
      Cells(Row, col).Copy 
      Worksheets("sheet 2").Range("G" & i).PasteSpecial xlPasteValues 
     End If 
    Next 
Next 

Do While Worksheets("sheet 2").Range("G" & i).Value <> "" 
    i = i + 1 
Loop 

End Sub 

Answer 1

おそらくこれは少し遅くなります（到着が遅いようですが）。

Sub CopyRangeToSingleColumn() 
    ' 20 Oct 2017 

    Dim LastRow As Long 
    Dim LastClm As Long 
    Dim Rng As Range, Cell As Range 
    Dim CellVal As Variant 
    Dim Spike(), i As Long 

    With ThisWorkbook.Worksheets("amount date") 
     With .UsedRange.Cells(.UsedRange.Cells.Count) 
      LastRow = Application.Max(Application.Min(.Row, 100), 51) 
      LastClm = .Column 
     End With 
     Set Rng = .Range(.Cells(51, "A"), .Cells(LastRow, LastClm)) 
    End With 

    ReDim Spike(Rng.Cells.Count) 
    For Each Cell In Rng 
     CellVal = Trim(Cell.Value)    ' try to access the sheet less often 
     If CellVal <> "" Then 
      Spike(i) = CellVal 
      i = i + 1 
     End If 
    Next Cell 

    If i Then 
     ReDim Preserve Spike(i) 
     With Worksheets("sheet 2") 
      LastRow = Application.Max(.Cells(.Rows.Count, "G").End(xlUp).Row, 2) 
      .Cells(LastRow, "G").Resize(UBound(Spike)).Value = Application.Transpose(Spike) 
     End With 
    End If 
End Sub 

上記のコードは、既存のセル値を上書きするのではなく、結果をG列に追加するように変更されました。

Answer 2

これは動作します：

Sub qwerty() 
    Dim i As Long, r As Long, c As Long 
    i = 1 

    ThisWorkbook.Worksheets("amount date").Select 
    For r = 51 To 100 
     For c = 2 To 1000 
      If Cells(r, c).Value <> "" Then 
       Cells(r, c).Copy 
       Worksheets("sheet 2").Range("G" & i).PasteSpecial xlPasteValues 
       i = i + 1 
      End If 
     Next 
    Next 
End Sub 

Answer 3

あなたが一つのセル、行ごとに行全体をコピーする必要がありますか？各ループのために速くなければならない。これはうまくいくと思います。

Sub RowToCell() 
Dim rng As Range 
Dim rRow As Range 
Dim rRowNB As Range 
Dim cl As Range 
Dim sVal As String 


Set rng = Worksheets("Sheet3").Range("$B$51:$ALN$100") 'check this range 
For Each rRow In rng.Rows 
    On Error Resume Next 
    Set rRowNB = rRow.SpecialCells(xlCellTypeConstants) 
    Set rRowNB = Union(rRow.SpecialCells(xlCellTypeFormulas), rRow) 
    On Error GoTo 0 

    For Each cl In rRowNB.Cells 
      sVal = sVal & cl.Value 
    Next cl 
    Worksheets("sheet4").Range("G" & rRow.Row - 50).Value = sVal 
    sVal = "" 
Next rRow 


End Sub 

この範囲ではすばやいです。