将范围复制到单个列中 – 仅限值

你好，我正试图复制范围到一个单一的列。 范围是空白单元格和值的单元格的组合。我只想复制和粘贴与值的单元格，我会find第一个空白单元格，并希望它自己走下来的列。

我现在的代码（除了永远）粘贴在第一行。

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 

其快速的这个范围。