I am trying move rows of values into a column in Excel. The transpose function works well, but will only move one row at a time. I would like to get a macro that will convert 173 rows of data across three columns into one column. Please see example below.
Thanks in advance for any help.
Rows:
98,058 98,058 98,314
82,362 82,684 83,326
93,410 93,479 93,761
Columns:
98,058
98,058
98,314
82,362
82,684
83,326
93410
93479
93761
The following will load the data from the CurrentRegion of A1 into an array and paste into one column, beginning in A5.
I'm assuming the data is numerical, contiguous and that this is a one-off, rather than an exercise that might have to be repeated on data sets of differing sizes. If your data is not contiguous, or not bound by empty cells, then you can hard code the range instead.
Private Sub transposeRows()
Dim inputRange As Variant
Dim myArray() As Long
Dim x As Long
Dim testCell As Range
'Get the range of data to copy'
Set inputRange = Range("A1").CurrentRegion
'Resize array to fit'
ReDim myArray(inputRange.Count - 1)
'Fill up array with data'
For Each testCell In inputRange
myArray(x) = testCell
x = x + 1
Next testCell
'Fill destination range'
Range("A5:A" & UBound(myArray) + 5) = WorksheetFunction.Transpose(myArray)
End Sub
Related
I've just started learning VBA, and I've been playing around with a subroutine that would take a random length column of numbers starting at cell A2, and create and output its transpose using application.transpose() somewhere else. This is my code.
Sub boxmatrix()
ActiveWorkbook.ActiveSheet.Select
Dim x()
Dim xt()
Range("A2").Select
ActiveCell.CurrentRegion.Select
n = ActiveCell.CurrentRegion.Rows.Count
ReDim x(1 To n)
ReDim xt(1 To n)
Dim range1 As Range
Dim range2 As Range
Dim range3 As Range
Set range1 = Range("A2").CurrentRegion
Set range2 = Range(Cells(1, 3), Cells(1, n + 2))
x = range1
xt = Application.Transpose(x)
range2.Value = xt
Debug.Print (x(1)) <--- THIS IS WHERE THE ERROR HAPPENS
End Sub
I've created the code that does accomplish those two things, but I've noticed that I can't do anything else, like multiply these two vectors to create a matrix, because my array x() isn't recognized as having numbers??
Any time I try to reference x(#), I get an error, whereas referencing xt(#) works perfectly fine, which is annoying as xt(#) was populated from the numbers supposedly in x(#) in the first place?
Assuming the CurrentRegion for cell A2 is just other cells in column A, then the statement
ReDim x(1 To n)
is creating a Variant array which is one-dimensional, with bounds 1 To n. But your subsequent statement
x = range1
is replacing that variable with a Variant array which is two-dimensional, with the first dimension having bounds 1 To n, and the second dimension having bounds 1 To 1.
So, to access the first row and first (and only) column, you can use:
Debug.Print x(1, 1)
I have not used VBA for sometime so am very rusty... What I have is a number of records stored vertically (in a single column) and I want to use VBA to stack them side by side (into a table).
My general thoughts about how this would flow:
Start at first range
Copy data
Paste data in cell B3 of output page (just named Sheet2)
Loop back to previous range and offset by 51 rows
Copy data
Paste data in cell C3 of output page (offset by 1 column each time)
My attempt so far:
Sub Macro1()
FiftyOne = 51 ' Offset by 51 rows for every chunk
StartRange = "L262:L303" ' Start at this range of data to copy, each chunk is identical in size
OutputRange = B3 ' Paste in output at B3, but need to offset by one column each time
Range(StartRange).Offset(FiftyOne, 0).Select
Selection.Copy
Sheets("Sheet2").Select
Range("B3").Offset(0, 1).Select
ActiveSheet.Paste
End Sub
I know this is a rather lame attempt to tackle this flow, but I am really struggling with how to loop through this. I would appreciate some advice on how to do this, or a better approach to the general flow.
Edit after accepting Wolfie's answer:
I want to assign column headings, by getting the values from C258 and looping down (in a similar way to before) 51 rows at a time, to paste into row 2 of sheet2 (B2, C2, ...).
Here is my current attempt:
Sub NameToTable()
' Assign first block to range, using easily changable parameters
' Remember to "Dim" all of your variables, using colon for line continuation
Dim blocksize As Long: blocksize = 51
Dim firstrow As Long: firstrow = 258
Dim rng As Range
Set rng = ThisWorkbook.Sheets("Sheet1").Range("C" & firstrow & blocksize - 1)
' tablestart is the upper left corner of the "pasted" table
Dim tablestart As Range: Set tablestart = ThisWorkbook.Sheets("Sheet2").Range("B2")
Dim i As Long ' Looping variable i
Dim nblocks As Long: nblocks = 10 ' We're going to loop nblocks number of times
For i = 0 To nblocks - 1
' Do the actual value copying, using Resize to set the number of rows
' and using Offset to move down the original values and along the "pasted" columns
tablestart.Offset(0, i).Resize(blocksize, 1).Value = _
rng.Offset(blocksize * i, 0).Value
Next i
End Sub
Your logic seems alright, this code will create a 51 x n table, lining up each vertical block of 51 cells in its own column.
Note, it's much quicker to assign the .Value than copying and pasting, if you need formats too then you could copy/paste or similarly set format properties equal.
Sub ColumnToTable()
' Assign first block to range, using easily changable parameters
' Remember to "Dim" all of your variables, using colon for line continuation
Dim blocksize As Long: blocksize = 51
Dim firstrow As Long: firstrow = 262
Dim rng As Range
Set rng = ThisWorkbook.Sheets("Sheet1").Range("L" & firstrow & ":L" & firstrow + blocksize - 1)
' tablestart is the upper left corner of the "pasted" table
Dim tablestart As Range: Set tablestart = ThisWorkbook.Sheets("Sheet2").Range("B3")
Dim i As Long ' Looping variable i
Dim nblocks As Long: nblocks = 10 ' We're going to loop nblocks number of times
For i = 0 To nblocks - 1
' Do the actual value copying, using Resize to set the number of rows
' and using Offset to move down the original values and along the "pasted" columns
tablestart.Offset(0, i).Resize(blocksize, 1).Value = _
rng.Offset(blocksize * i, 0).Value
Next i
End Sub
Set the nblocks value to suit your needs, this is the number of resulting columns in your output table. You could get it dynamically by knowing the number of rows in the original column. Or you could use some while logic, careful to make sure that it does eventually exit of course!
Dim i As Long: i = 0
Do While rng.Offset(blocksize*i, 0).Cells(1).Value <> ""
tablestart.Offset(0, i).Resize(blocksize, 1).Value = rng.Offset(blocksize * i, 0).Value
i = i + 1
Loop
Edit: to get your column headings, keep in mind that the column headings are only 1 cell, so:
' Change this:
Set rng = ThisWorkbook.Sheets("Sheet1").Range("C" & firstrow & blocksize - 1)
' To this:
Set rng = ThisWorkbook.Sheets("Sheet1").Range("C" & firstrow)
Tip: + is used for adding numerical values, whilst & is used for concatenating stings.
Now when you're looping, you don't need the Resize, because you are only assigning 1 cell's value to 1 other cell. Resulting sub:
Sub NameToTable()
Dim blocksize As Long: blocksize = 51
Dim firstrow As Long: firstrow = 258
Dim rng As Range
Set rng = ThisWorkbook.Sheets("Sheet1").Range("C" & firstrow)
Dim tablestart As Range: Set tablestart = ThisWorkbook.Sheets("Sheet2").Range("B2")
Dim i As Long: i = 0
Do While rng.Offset(blocksize*i, 0).Value <> ""
tablestart.Offset(0, i).Value = rng.Offset(blocksize * i, 0).Value
i = i + 1
Loop
End Sub
When dealing with your worksheets in excel, each time you reference them adds overhead and slows down the code, what you want to do is take all of the info off your spreadsheet into an array then use Application.Transpose to transpose it for you.
You can then use 'Resize' to make sure your destination range is the same size and set the values.
Sub CopyAndTransRange(src As Range, dest As Range)
Dim arr As Variant 'Needs to be a variant to take cell values
arr = Application.Transpose(src.Value) 'Set to array of values
On Error GoTo eh1dim 'Capture error from vertical 1D range
dest.Resize( _
UBound(arr, 1) - LBound(arr, 1) + 1, _
UBound(arr, 2) - LBound(arr, 2) + 1 _
) = arr 'Set destination to array
Exit Sub
eh1dim:
dest.Resize( _
1, _
UBound(arr) - LBound(arr) + 1 _
) = arr 'Set row to 1D array
End Sub
Note, Application.Transpose will fall over with some arrays in weird circumstances like if there is more than 255 characters in a string in the given array, for those situations you can write your own Transpose function to flip the array for you.
Edit:
When you feed a vertical 1-dimensional range and transpose it, VBA converts it to a 1-dimensional array, I've rewritten so it captures the error when this happens then adjusts accordingly.
Just made this example which has values 1 through 7 populated on the first 7 rows of column A. This code effectively loops through each of the values, and transposes horizontally so all values are on a single row (1).
Dim rng As Range
Dim crng As Range
Static value As Integer
Set rng = ActiveSheet.Range("A1", Range("A1").End(xlDown))
For Each crng In rng.Cells
ActiveSheet.Range("A1").Offset(0, value).value = crng.value
If value <> 0 Then
crng.value = ""
End If
value = value + 1
Next crng
First we grab the required range and then iterate through each cell. Then using the offset method and an incrementing integer, we can assign their values horizontally to a single row.
It's worth noting that this would work when trying to transpose both vertically and horizontally. The key is the offset(column, row).
Just adjust where you place your incrementing Integer.
Hope this helps.
QUESTION
How can I perform a copy of a list of cells, without selecting them?
Say I want to copy the ranges A1, A5 and A7.
They are stored in a string like this: addr = "A1,A5,A7"
If I select them first and copy them, the action works fine:
Range(addr).Select
Selection.Copy
When I paste from my clipboard, I only have the values I selected.
Also, if I perform a Union of Range as suggested here, it would work too without selecting:
Dim rng1 As Range, rng2 As Range, rng3 As Range, rngUnion As Range
Set rng1 = Range("A1")
Set rng2 = Range("A5")
Set rng3 = Range("A7")
Set rngUnion = Union(rng1,rng2,rng3)
rngUnion.Copy
However, I cannot neither select the ranges first, nor knowing before runtime how many ranges I will have to select.
I've tried to do this:
Range(addr).Copy
but when I perform the paste it takes all the values between A1 and A7 (basically A1:A7).
How can I get to copy the single cells without selecting them or uniting them?
BACKGROUND - not necessary to answer the question I guess
I have a listbox in which there is a list of values, that the user can multi-select (they can select like the first, the fourth, the seventh line etc.).
When they do that, I build a collection containing those values:
["value1", "value2", "value3", ... ]
Those values are unique in the spreadsheet (if I run a Find, I only can find one range).
As you can guess, I don't know in advance how many values there will be in the collection.
What I need to do is to make them copy their selection. Hence, I build a collection based on those values:
For j = 0 To Me.longList.ListCount - 1
If Me.longList.Selected(j) Then
tmpColl.Add Split(Split(Me.longList.List(j), " ")(1), " ")(0) '<-- add the story ID to the collection
End If
Next j
and then, I build the string holding the address of my multi-selection:
For j = 1 To tmpColl.Count
With Sheets("Stories list")
Set rng = .Range("A1:A10000").Find(tmpColl(j), lookAt:=xlWhole)
addr = addr & "$A$" & rng.Row & ","
End With
Next j
addr = Left(addr, Len(addr) - 1)
Something like this should work without needing to select the entries. It will split the cell addresses into an array, then iterate those to add the values into a new array for outputting to a sheet.
I've put values in A1,A3,A5, and that will move it to column B. All the code assumes this is working on the ActiveSheet.
Option Explicit
Sub SO_Example()
'Assign a string with the range you want to add
Dim addStr As String: addStr = "A1,A3,A5"
'Split the string by a comma to create an array of cells
Dim cellArr As Variant: cellArr = Split(addStr, ",")
Dim i As Long
'Resize the OutArray to be as large as the number of cells to select
Dim arrOut As Variant: ReDim arrOut(UBound(cellArr))
'Add the items to the array
For i = LBound(cellArr) To UBound(cellArr)
arrOut(i) = Range(cellArr(i)).Value
Next
'Output to column B
Range("B1:B" & i).Value = WorksheetFunction.Transpose(arrOut)
End Sub
I don't know how to best describe this but it's better that I explain my problem in pictures.
I have 2 worksheets:
In worksheet Array, there are certain periods with their corresponding 'Array' associated with them.
In Sheet1, there is a list of strings in the format: dd/mm/yyyy hh:mm:ss AM/PM - # ordered by ascending order of number, then by date and finally by time.
The code I have, generates those values in Sheet1 by extracting the data in Array and listing them out in one cell. The code I've used is.
Sub Filter()
Const Array_FirstRow As Integer = 2 'Indicates the first row (row 2) in Array sheet
Dim Array_RowIndex As Integer 'variable to loop through array values of col A
Dim Summary_PeriodMoment1 As String 'in worksheet Sheet 1
Array_RowIndex = Array_FirstRow
Array_LastRow = Array_RowIndex - 1
Summary_PeriodMoment1 = ""
For Array_RowIndex = Array_FirstRow To Array_LastRow
If Summary_PeriodMoment1 <> " " Then
Summary_PeriodMoment1 = Summary_PeriodMoment1 & ", " & Worksheets("Array").Cells(Array_RowIndex, Array_DateTime_Column).Value
End If
Next
Sheet1.Cells(1, 1).Value = Summary_PeriodMoment1
End Sub
This is slightly confusing and overly complicated to read. Is there any way to add code to :
Sort/group the values by # and consolidate by date (to make it less confusing)? Like so?
Have a separate cell for each value, again categorized by # (I would like to plot these values on a pivot graph later on using other code, so would like it to be in a friendly format
Essentially I would like to do some data reformatting/transposing with a VBA script. Any idea what functions I should use? thanks!
+++++++++++++++++++++++++++++++++++++++++++++++++++++++++
Update: I have what I need for transposing a string of values in one cell. I wonder if this can be done for multiple cells. I tried using this code:
Sub TextToRows()
'Code for 1.2. section
Dim Arr As Variant
Dim Arr1 As Variant
Dim Arr2 As Variant
Dim InputRng As Range, InputRng2 As Range, InputRng3 As Range, OutputRng As Range, OutputRng1 As Range, OutputRng2 As Range
Set InputRng = Range("B1") 'Cell Containing all the text
Set InputRng1 = Range("B2")
Set InputRng2 = Range("B3")
Set OutputRng = Range("D1") 'First Cell of a column that you want the output there
Set OutputRng1 = Range("G1")
Set OutputRng2 = Range("J1")
Arr = Split(InputRng.Value, ",")
Arr1 = Split(InputRng.Value, ",")
Arr2 = Split(InputRng.Value, ",")
Set OutputRng = OutputRng.Resize(UBound(Arr) - LBound(Arr) + 1)
OutputRng.Value = Application.Transpose(Arr)
Set OutputRng1 = OutputRng1.Resize(UBound(Arr1) - LBound(Arr1) + 1)
OutputRng.Value = Application.Transpose(Arr1)
Set OutputRng2 = OutputRng2.Resize(UBound(Arr2) - LBound(Arr2) + 1)
OutputRng.Value = Application.Transpose(Arr2)
End Sub
Seems it only works for InputRng and not InputRng1 or InputRng2
1.
How to split comma-delimited data in one cell? (Look below)
1.1. If you don't have any other data, and number of records are not more than number of possible columns in excel then transposing within the worksheet is an option (Instead of using the code below).
1.2. (If you have more data than limit of excel columns): Otherwise, you need to use arrays. The code below answers first part of your question. It will split the cell for "," as delimiter.
2.
Then you can use Text to Columns in Data tab and delimiter ":" to get the numbers in one column and dates in another one.
3.
Use How To Transpose Cells In One Column Based On Unique Values In Another Column? to group them based on the numbers.
Sub TextToRows()
'Code for 1.2. section
Dim Arr As Variant
Dim InputRng As Range, OutputRng As Range
Set InputRng = Range("B1") 'Cell Containing all the text
Set OutputRng = Range("D1") 'First Cell of a column that you want the output there
Arr = Split(InputRng.Value, ",")
Set OutputRng = OutputRng.Resize(UBound(Arr) - LBound(Arr) + 1)
OutputRng.Value = Application.Transpose(Arr)
End Sub
I have 2 sheets, "Report" and "Data". In the "Data" sheet are values in column A as follows T-Shirt.Adidas.25.110 I need to take the raw data and input them into the "Report" Sheet as separate entities.
ex. Cell A1 will read "T-Shirt" Cell B1 will read "Adidas"
Here is what I have so far. Its a with statement but that will only work for one line. Im not sure how to loop it.
Dim Cell As Object
Dim Data As Range
Dim Report As Range
Set Report = Worksheets("Report").Range("A2", Range("A2").End(xlDown))
Set Data = Worksheets("Data").Range("A2", Range("A2").End(xlDown))
With Report
.Resize(1, 4) = Split(Worksheets("Data").Range("A2"), ".")
End With
The macro needs to work for any number of objects in the data sheet.
Thanks in advance!
Here is one way to loop:
Sub test()
Dim Cell As Object
Dim Data As Range
Dim Report As Range
Dim i As Long, TempArray As Variant
Set Data = Worksheets("Data").Range("A2", Worksheets("Data").Range("A2").End(xlDown))
Set Report = Worksheets("Report").Range("A2")
For i = 1 To Data.Count
TempArray = Split(Data.Range("A" & i), ".")
Report.Offset(i - 1).Resize(1, UBound(TempArray) + 1) = TempArray
Next i
Set TempArray = Nothing
End Sub
This way you use the Data as the source and count of iterations, and you can generalize the columns based on the number of periods in a given piece of data.