Advertisement
lilysecret

Move Range to Single Column

Feb 1st, 2023
1,368
0
Never
Not a member of Pastebin yet? Sign Up, it unlocks many cool features!
  1. Sub MoveRangeToColumn()
  2. ''moves a block of cells into a single column
  3.  
  4. Dim srcRange As Range
  5. Dim dstRange As Range
  6. Dim ic As Integer
  7. Dim ir As Integer
  8. Dim cel As Range
  9. Dim numCells As Integer
  10. Dim ws As Worksheet
  11. Dim numRows As Integer
  12. Dim numCols As Integer
  13. Dim newColumn As Range
  14. Dim newColCount As Integer
  15.  
  16.  
  17. On Error Resume Next
  18.  
  19. ''have the user select the range of cells to be stacked
  20. Set srcRange = Application.InputBox(Title:="Source Range", Prompt:="Select the source range to stack. Do not include headers.", Type:=8)
  21. On Error GoTo 0
  22.  
  23. 'Test for cancel.
  24. If srcRange Is Nothing Then Exit Sub
  25.  
  26. 'Test for single-cell selection.
  27. 'Remove comment character if single-cell selection is okay.
  28. If srcRange.Rows.Count = 1 Then
  29.     MsgBox "You’ve selected only one cell." & "Please select multiple contiguous cells.", vbOKOnly
  30. Exit Sub
  31.  
  32. End If
  33.  
  34. MsgBox srcRange.Address
  35. ''have the user select the first cell of the destination range
  36. Set dstRange = Application.InputBox(Title:="Source Range", Prompt:="Please select the first cell of the destination column. Select one cell only.", Type:=8)
  37. On Error GoTo 0
  38.  
  39. 'Test for cancel.
  40. If dstRange Is Nothing Then Exit Sub
  41.  
  42. ''test if the user has selected more than one cel
  43. If dstRange.Rows.Count > 1 Then
  44.     MsgBox "You’ve selected more than one cell." & "Please select only one cells", vbOKOnly
  45. Exit Sub
  46.  
  47. End If
  48. MsgBox dstRange.Address
  49.  
  50. ''Set srcRange = ActiveSheet.Range("E4:J12")
  51. ''Set dstRange = ActiveSheet.Range("N4")
  52. numCells = srcRange.Cells.Count
  53. numRows = srcRange.Rows.Count
  54. numCols = srcRange.Columns.Count
  55. newColCount = 1
  56.  
  57. ''MsgBox numCells & "," & numRows & "," & numCols
  58. ''Debug.Print srcRange.Item(1, 1).Address
  59.  
  60. For ic = 1 To numCols
  61.     For ir = 1 To numRows
  62.         dstRange(newColCount, 1).Value = srcRange.Cells(ir, ic).Value
  63.         Debug.Print dstRange(newColCount, 1).Value
  64.         newColCount = newColCount + 1
  65.     Next ir
  66. Next ic
  67.  
  68.    
  69.  
  70.  
  71. End Sub
Advertisement
Add Comment
Please, Sign In to add comment
Advertisement