I have a dataset that I’m trying to reorient but Excel’s transpose function won’t work for what I’m trying to do. I do want to transpose the original data from rows to columns but instead I’m hoping to stack the data from each row of the original data into a single column in a separate sheet. In other words, if I have an array made up of 3 rows and 3 columns, I want to copy and paste the data so that the 9 cells of the original array become a 1 by 9 array in a separate sheet.
My VBA skills are elementary at best and I’ve attempted to write a macro with a For Next loop but just cannot seem to get it right. Any suggestions?
This code will convert a range of cells into a unidimensional array:
Dim rngSource As Range
Dim rng As Range
Dim MiMatriz() As Integer
Dim MiPos As Integer
Dim i As Integer
Set rngSource = Range("A1").CurrentRegion
ReDim MiMatriz(1 To 1, 1 To rngSource.Cells.Count)
For Each rng In rngSource.Cells
MiPos = (((rng.Row - rngSource.Cells(1, 1).Row + 1) - 1) * rngSource.Columns.Count) + (rng.Column - rngSource.Cells(1, 1).Column + 1)
MiMatriz(1, MiPos) = rng.Value
Next rng
For i = 1 To rngSource.Cells.Count
Debug.Print "Index:(1," & i & ")", MiMatriz(1, i)
Next i
Erase MiMatriz
Set rngSource = Nothing
The output I get when executing this code is:
Index:(1,1) 1
Index:(1,2) 2
Index:(1,3) 3
Index:(1,4) 4
Index:(1,5) 5
Index:(1,6) 6
Index:(1,7) 7
Index:(1,8) 8
Index:(1,9) 9
Related
Closed. This question needs to be more focused. It is not currently accepting answers.
Want to improve this question? Update the question so it focuses on one problem only by editing this post.
Closed 2 years ago.
Improve this question
I am currently struggling to gain traction on this problem. The goal that I am trying to accomplish is to some how group rows that are most alike together. The setup: all rows are independent of one another but they can have any number of column values in that same row (up to 10). I am looking for a solution to help me find the rows that have 3 or more common values across the 10 columns and highlight them accordingly. I am just now getting into excel VBA and I have the feeling that is the direction I need to head in. I will provide a simplified set of data that I would like to do this for. In the picture, the goal I am trying to achieve is "group" rows 8 and 10 together because they have 3 or more column matches. Any help would be much appreciated!
update: I am unable to provide the data that I am actually going to use this for, but the script needs to be able to handle alpha-numeric values (ex: MELP7899797). THANK YOU FOR THE HELP SO FAR!!!!
Please try this code. Note that you must set the constant TopLeftCell at the top to tell the macro where your data are. In your sample the top left cell is A1. I tested with a blank row above the data so that the top-left was in A2.
Sub MarkMatches()
' 033
Const TopLeftCell As String = "A2" ' change to match where your data are
Dim Rng As Range ' data range
Dim FirstRow As Long, FirstClm As Long
Dim Data As Variant ' original data (2-D)
Dim Arr As Variant ' data rearranged (1-D)
Dim Tmp As Variant ' working variable
Dim R As Long, R1 As Long ' row counters
Dim C As Long ' column counter
Dim Count() As String ' match counter
With Range(TopLeftCell)
FirstRow = .Row
FirstClm = .Column
End With
C = Cells(FirstRow, Columns.Count).End(xlToLeft).Column
Set Rng = Range(Cells(FirstRow, FirstClm), _
Cells(Rows.Count, FirstClm).End(xlUp).Offset(0, C - FirstClm))
Data = Rng.Value
ReDim Arr(1 To UBound(Data))
For R = 1 To UBound(Data)
ReDim Tmp(1 To UBound(Data, 2))
For C = 1 To UBound(Data, 2)
Tmp(C) = Data(R, C)
Next C
Arr(R) = Tmp
Next R
ReDim Count(1 To UBound(Arr))
For R = 1 To UBound(Arr) - 1
For R1 = R + 1 To UBound(Arr)
Tmp = 0
For C = 1 To UBound(Arr(R))
If Not IsError(Application.Match(Arr(R)(C), Arr(R1), 0)) Then
Tmp = Tmp + 1
End If
Next C
If Tmp > 0 Then ' change to suit
Tmp = Format(Tmp, "(0)") & ", "
Count(R) = Count(R) & CStr(R1 + FirstRow - 1) & Tmp
Count(R1) = Count(R1) & CStr(R + FirstRow - 1) & Tmp
End If
Next R1
Next R
For R = 1 To UBound(Count)
If Len(Count(R)) Then Count(R) = Left(Count(R), Len(Count(R)) - 2)
Next R
' set the output column here (2 columns right of the last data column)
' to avoid including this column in the evaluation
' it must be blank before a re-run
Set Rng = Rng.Resize(, 1).Offset(0, UBound(Data, 2) + 1)
Rng.Value = Application.Transpose(Count)
End Sub
The code will produce a result as shown below and write it to a blank column, right of the data. (Note that the code presumes that all data in the sheet are for evaluation, except those above or to the left of TopLeftCell).
Read 4(4) (in the first row, which is row 2 of the sheet) to mean that there were 4 matches compared to row 4. In row 4 you will find the matching info, 2(4) indicating that there were 4 matches with row 2. The result displays all matches except zero. This outcome is governed by this line of code.
If Tmp > 0 Then ' change to suit
If you change it to Tmp => 3 you could exclude the noise. Of course, the result could also be applied in a totally different way. However, simply coloring matching rows won't do. As you see, there are quite a few qualifying rows and applying color to all of them would hide the information now available, i.e. which rows match with which other rows.
Given the lack of elegance with the data
the record sheet continues for many MANY rows, each entry having its own set of identical headings
I was hoping to just extract the data from rows 7, 14 and so on, then populate the data into a simple table to be used on the 'Protocol Summary' form, then sort them all into alphanumeric order based on the data that is in the A column so they all become grouped by 'Event Type'.
Because the potential data that could be under the 'Event Type' heading can vary a lot (generally has the format of [number 1-32/letter/number 1-30] but can also be all letters, with a few thousand possibilities, I thought it might be easier to filter the other lines OUT, given they don't change. I would love to redesign the table, but unfortunately it's not my table so I have to work with what I'm given.
Thanks for your time.
This will loop over your sheet up to the last used row, starting from Row 7 and stepping 7 rows each iteration.
Within each iteration, each cell in the row is written into an array which is then written to another sheet ready for sorting (however you want to do that).
This code is sample and may not work by copy/paste.
I have written this in the Sheet1 code module, so Me refers to ThisWorkbook.Sheets("Sheet1").
I have made this from a blank workbook and did not rename any sheets therefore you will need to make adjustments to any sheet references to match your appropriate sheet names.
The code will only reference columns A, B and C in the TargetRow (I only tested with 3 columns of data as I don't know your working range). I'll reference what to update to extend this after the code block.
Currently the array is put back into Sheet2 starting from cell A2. This is assuming row 1 contains table headers as this will write the data directly into the table format. Naturally if you want to change where the data is written, change the cell it is written to (when writing an array to sheet, you only need to define the top left cell of the range it is written to, Excel works out the rest based on the size and dimensions of the array).
Sub WriteEverySeventhRowToAnotherSheet()
Dim SeventhRowCount As Long
Dim myArray() As Variant
Dim lastrow As Long
Dim TargetCell As Variant
Dim TargetRow As Range
Dim ArrFirstDimension As Long
Dim ArrSecondDimension As Long
lastrow = Me.Range("A" & Me.Rows.Count).End(xlUp).Row
ReDim myArray(1 To lastrow / 7, 1 To 3)
ArrFirstDimension = 1
ArrSecondDimension = 1
'------------------Loop over every 7th row and enter row data to array---------------
For SeventhRowCount = 7 To lastrow Step 7
Set TargetRow = Me.Range("A" & SeventhRowCount & ":C" & SeventhRowCount)
For Each TargetCell In TargetRow
If Not ArrSecondDimension > UBound(myArray) Then
myArray(ArrFirstDimension, ArrSecondDimension) = TargetCell
'Debug.Print TargetCell
ArrSecondDimension = ArrSecondDimension + 1
End If
Next TargetCell
ArrFirstDimension = ArrFirstDimension + 1
ArrSecondDimension = 1
Set TargetRow = Nothing
Next SeventhRowCount
'---------------------Write array to another sheet------------------
Dim Destination As Range
Set Destination = ThisWorkbook.Sheets("Sheet2").Range("A2")
Destination.Resize(UBound(myArray, 1), UBound(myArray, 2)).Value = myArray
End Sub
To extend the number of columns the loop will write to the array, change the following instance of C to the correct column letter (in the below line the range is set from Column A to Column C):
Set TargetRow = Me.Range("A" & SeventhRowCount & ":C" & SeventhRowCount)
Also change the 2nd dimension of the Array to match the number of the Column set above (i.e Column E = 5 and Column L = 13 etc.) - You need to replace the number 3 with the correct number.
ReDim myArray(1 To lastrow / 7, 1 To 3)
I have a block of data which I define as a range ("ARRAY_DIM") in excel. The range includes a lot of data but also have many rows and columns with no data at all. Below is an example of the defined range. Please note that the number of data columns for each identifier varies which is why the ARRAY_DIM is defined with +100 columns (of which only few rows will contain data).
Banana 10 20 30 40 50 70
Parrot 5 1 4 30
Apple 3 3 5 6 20
Car 10 20 30 40 30
Donkey 4 12 3 0 4 5
Coconut 10 4 0 1
I am inserting all of this data into an array such that I can loop through a list of relevant identifiers and then paste the data associated with the identifiers in the adjacent cells (same row). See below for a simplified example of identifiers (first column is a range defined as "OUTPUT") and where I intend to paste the relevant data for identifiers that are included in the array.
Banana 10 20 30 40 50 70
SHARK
Apple 3 3 5 6 20
Airplane
I am having troubles with accomplishing this task based on the code below. It works fine for the first row/identifier but then I get an error "Subscript out of range" at the .Cells output line. I would appreciate if someone can review the code and maybe point out any errors.
Sub test()
Dim arr As Variant
Dim cell As Range
With ThisWorkbook.Sheets("Sheet1")
arr = .Range("ARRAY_DIM")
End With
With ThisWorkbook.Sheets("Sheet2")
For Each cell In .Range("OUTPUT")
For x = LBound(arr, 1) To UBound(arr, 1)
If arr(x, 1) = cell.Value Then
For n = LBound(arr, 1) To UBound(arr, 1)
.Cells(cell.Row, n + 2) = arr(x, n + 1)
Next n
End If
Next x
Next cell
End With
End Sub
This should handle it, assuming unique labels in the first columns:
Dim data As Object
Dim r As Range
Dim thisName As String
Dim thisData As Range
Set data = CreateObject("Scripting.Dictionary")
With ThisWorkbook.Sheets("Sheet1")
' Store each row in our Dictionary with key=item name, value=row values
For Each r In .Range("ARRAY_DIM").Rows
Set data(r.Cells(1).Value) = r.Resize(1, r.Columns.Count - 1).Offset(0, 1)
Next
End With
With ThisWorkbook.Sheets("Sheet2")
For Each r In .Range("OUTPUT").Columns(1).Cells
thisName = r.Cells(1).Value
' Check if thisName exists in our Dictionary
If data.Exists(thisName) Then
' Dump the data into the row if it exists
Set thisData = data(thisName)
r.Offset(0, 1).Resize(1, thisData.Columns.Count).Value = thisData.Value
End If
Next
End With
But I think that can be further simplified to a single loop:
Dim r As Range
Dim thisName As String
Dim thisData As Range
Dim outputRow As Variant
Dim outputRange as Range
Set outputRange = ThisWorkbook.Sheets("Sheet2").Range("OUTPUT")
With ThisWorkbook.Sheets("Sheet1").Range("ARRAY_DIM")
For Each r In .Rows
thisName = r.Cells(1).Value
' Check whether thisName exists in outputRange
outputRow = Application.Match(thisName, outputRange, False)
If Not IsError(outputRow) Then
' Dump this row's Values to the outputRange
outputRange.Rows(outputRow).Value = r.Value
End If
Next
End With
NB: Neither of the above approaches will add a new row if the thisName isn't found in the OUTPUT range.
Am trying to parse an excel file using Excel VBA.
Here is the sample sata
I did some research and found you can assign ranges to array like
Arrayname = Range("A1:D200")
But am looking for some thing more dynamic, like add the below multiple ranges to a single array.
and my final array will be a single array/table with n is number of rows from all ranges and 4 columns.
Can any one please prvide me a example.
Thank you in adavance.
I think you are asking for more information about moving data between ranges and variables so that is the question I will attempt to answer.
Create a new workbook. Leave Sheet1 empty; set cell B3 of Sheet2 to "abc" and set cells C4 to F6 of Sheet3 to ="R"&ROW()&"C"&COLUMN()
Open the VB Editor, create a module and copy the follow code to it. Run macro Demo01().
Option Explicit
Sub Demo01()
Dim ColURV As Long
Dim InxWkSht As Long
Dim RowURV As Long
Dim UsedRangeValue As Variant
' For each worksheet in the workbook
For InxWkSht = 1 To Worksheets.Count
With Worksheets(InxWkSht)
Debug.Print .Name
If .UsedRange Is Nothing Then
Debug.Print " Empty sheet"
Else
Debug.Print " Row range: " & .UsedRange.Row & " to " & _
.UsedRange.Row + .UsedRange.Rows.Count - 1
Debug.Print " Col range: " & .UsedRange.Column & " to " & _
.UsedRange.Column + .UsedRange.Columns.Count - 1
End If
UsedRangeValue = .UsedRange.Value
If IsEmpty(UsedRangeValue) Then
Debug.Print " Empty sheet"
ElseIf VarType(UsedRangeValue) > vbArray Then
' More than one cell used
Debug.Print " Values:"
For RowURV = 1 To UBound(UsedRangeValue, 1)
Debug.Print " ";
For ColURV = 1 To UBound(UsedRangeValue, 2)
Debug.Print " " & UsedRangeValue(RowURV, ColURV);
Next
Debug.Print
Next
Else
' Must be single cell worksheet
Debug.Print " Value = " & UsedRangeValue
End If
End With
Next
End Sub
The following will appear in the Immediate Window:
Sheet1
Row range: 1 to 1
Col range: 1 to 1
Empty sheet
Sheet2
Row range: 3 to 3
Col range: 2 to 2
Value = abc
Sheet3
Row range: 4 to 6
Col range: 3 to 5
Values:
R4C3 R4C4 R4C5
R5C3 R5C4 R5C5
R6C3 R6C4 R6C5
If you work through the macro and study the output you will get an introduction to loading a range to a variant. The points I particularly want you to note are:
The variable to which the range is loaded is of type Variant. I have never tried loading a single range to a Variant array since the result may not be an array. Even if it works, I would find this confusing.
Sheet1 is empty but the used range tells you than cell A1 is used. However, the variant to which I have loaded the sheet is empty.
The variant only becomes an array if the range contains more than one cell. Note: the array will ALWAYS be two dimensional even if the range is a single row or a single column.
The lower bounds of the array are ALWAYS 1.
The column and row dimensions are not standard with the rows as dimension 1 and the columns as dimension 2.
If there is any doubt about the nature of the range being loaded, you must use IsEmpty and VarType to test its nature.
You may also like to look at: https://stackoverflow.com/a/16607070/973283. Skim the explanations of macros Demo01() and Demo02() which are not relevant to you but set the context. Macro Demo03() shows the advanced technique of loading multiple worksheets to a jagged array.
Now create a new worksheet and leave it with the default name of Sheet4.
Add the follow code to the module. Run macro Demo02().
Sub Demo02()
Dim ColOut As Long
Dim OutputValue() As String
Dim Rng As Range
Dim RowOut As Long
Dim Stg As String
ReDim OutputValue(5 To 10, 3 To 6)
For RowOut = LBound(OutputValue, 1) To UBound(OutputValue, 1)
For ColOut = LBound(OutputValue, 2) To UBound(OutputValue, 2)
OutputValue(RowOut, ColOut) = RowOut + ColOut
Next
Next
With Worksheets("Sheet4")
Set Rng = .Range("A1:D6")
End With
Rng.Value = OutputValue
With Worksheets("Sheet4")
Set Rng = .Range(.Cells(8, 2), .Cells(12, 4))
End With
Rng.Value = OutputValue
With Worksheets("Sheet4")
Stg = "C" & 14 & ":G" & 20
Set Rng = .Range(Stg)
End With
Rng.Value = OutputValue
End Sub
Although this macro writes an array to a worksheet, many of the points apply for the opposite direction. The points I particularly want you to note are:
For output, the array does not have to be Variant nor do the lower bounds have to be 1. I have made OutputValue a String array so the values output are strings. Change OutputValue to a Variant array and rerun the macro to see the effect.
I have used three different ways of creating the range to demonstrate some of your choices.
If you specify a range as I have, the worksheet is one of the properties of the range. That is why I can take Rng.Value = OutputValue outside the With ... End With and still have the data written to the correct worksheet.
When copying from a range to a variant, Excel sets the dimensions of the variant as appropriate. When copying from an array to a range, it is your responsibility to get the size of the range correct. With the second range, I lost data. With the third range, I gained N/As.
I hope the above gives you an idea of your options. If I understand your requirement correctly, you will have to:
Load the entire worksheet to Variant
Create a new Array of the appropriate size
Selectively copy data from the Variant to the Array.
Come back withh questions if anything is unclear.
How do I use the lastRow variable in the sum function in vba? After I count the number of words in each row until the last row, I would like to add up the individual totals from each row into an overall total column but I do not want to hard code the range into the sum function in vba? Is there another way?
Example:
Column: A B C D E F
NRow 1: 2 3 4 5 6 7
NRow 2: 3 4 5 6 7 8
Total 3: 5 7 9 11 13 15
Want to avoid SUM(R[-2]C:R[-1]C)? I would like SUM(R[lastRow]C:R[-1]C) or something that would function in the same way.
Thank you!
Something like this which
Sets the usedrange on the active sheet from A1 to the last used cell in column F
Goes to the first cell below this range Cells(rng1.Cells(1).Row + rng1.Rows.Count, 1), resizes to the amount of columns in the range of interest (6 in this case)
Enters the forumula "=SUM(R[-" & rng1.Rows.Count & "]C:R[-1]C)" where rng1.Rows.Count gives the first row dynamically
code
Sub GetRange()
Dim rng1 As Range
Set rng1 = Range([a1], Cells(Rows.Count, "F").End(xlUp))
Cells(rng1.Cells(1).Row + rng1.Rows.Count, 1).Resize(1, rng1.Columns.Count).Value = "=SUM(R[-" & rng1.Rows.Count & "]C:R[-1]C)"
End Sub
If you can guarantee that there is always data in column A then to find the last row you could do the following:
Option Explicit
Sub addSums()
Dim lstRow As Integer
With Excel.ThisWorkbook.Sheets("Sheet1")
lstRow = .Cells(.Rows.Count, 1).End(Excel.xlUp).Row
Dim j As Integer
For j = 1 To .Cells(1, .Columns.Count).End(Excel.xlToLeft).Column
.Cells(lstRow + 1, j) = "=SUM(R[-" & lstRow - 1 & "]C:R[-1]C)"
.Cells(lstRow + 1, j).Font.Bold = True
Next j
End With
End Sub
Seems to work ok on the following:
If your source data is coming frm an external source, the appropriate mechanism is:
Create a Named Data Range around the input table;
Set the inut table to automatically resize on refresh; and
Then use the Named Data Range in your functions.