Copier une plage dans une seule colonne - valeurs uniquement

Question

Bonjour J'essaie de copier une plage dans une seule colonne. La plage est un mélange de cellules vides et de cellules avec des valeurs. Je veux seulement copier et coller les cellules avec des valeurs et je voudrais qu'il trouve la première cellule vide et qu'il veuille se promener dans la colonne à partir de là.

Le code que j'ai en ce moment (en plus de prendre pour toujours) colle dans la première rangée.

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

Peut-être que ce sera un peu plus rapide (même s'il semble avoir été lent à arriver).

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 

Le code ci-dessus a été modifié pour ajouter le résultat à la colonne G au lieu de remplacer les valeurs de cellule existantes.

Answer 2

Cela fonctionne:

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

Avez-vous besoin de copier toute la ligne dans une cellule, ligne par ligne? Pour chaque boucle doit être plus rapide. Je suppose, cela devrait fonctionner

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 

son rapide pour cette gamme.