I have an Excel table.
And I need to write its data into a single column, row by row, every row is "read" from left to right, zeroes excluded. Please look at the picture to understand better:
Is there a way to do it quickly using VBA? I tried using only formulas and it worked, but it took several steps (creating a column, excluding zeroes, re-writing the column...) and really slowed down the whole process.
To copy all the non empty values from a range to a single column:
Dim source(), arr(), r&, c&, i&
' read the data from the range
source = [A1:G3].Value2
' copy the non empty value
ReDim arr(1 To UBound(source, 1) * UBound(source, 2), 1 To 1)
For r = 1 To UBound(source, 1)
For c = 1 To UBound(source, 2)
If source(r, c) <> Empty Then
i = i + 1
arr(i, 1) = source(r, c)
End If
Next
Next
' write the data back to the sheet
[A7].Resize(i, 1) = arr
Related
I'm having trouble with a specific process.
In column H, there are a bunch of different numbers. I'm looking for a loop, that for each newfound value in the column, counts how many times the value occur in that column, and put's the counted value in the next worksheet "Statistik".
I do have a solution were I make a code for each individual number in the column, but i'm looking for a loop, since there are 28 different values ind that column.
Image of my workbook
Does anyone have a bright solution for my problem?
Thanks in advance.
You need to use COUNTIF. Either as a formula or in your VBA code (Application.CountIf()).
In your case =COUNTIF(H:H, [UNIQUE_VALUE]) where unique value is the value you want to extract. To get unique values you have two options. One is to copy unique values from H:H to your Statistik sheet as follows:
Click the Data Ribbon Menu
Select the Advanced Button in the Sort & Filter section
Fill in the dialog Box, Copy to another location, List range H:H, Copy to Some column in Statistik sheet* making sure you tick **Unique records only
Other option to get unique values is detailed here https://exceljet.net/formula/extract-unique-items-from-a-list
For more information about COUNTIF
https://support.office.com/en-us/article/countif-function-e0de10c6-f885-4e71-abb4-1f464816df34
You could use a dictionary to output only 1 key and value
Option Explicit
Public Sub GetCount()
Dim dict As Object
Set dict = CreateObject("Scripting.Dictionary")
With Worksheets("Sheet1") 'change as appropriate
Dim arr(), i As Long
arr = Intersect(.Columns("H"), .UsedRange) '<=== Specify exact range in H to loop over if you want including header
For i = LBound(arr, 1) + 1 To UBound(arr, 1) 'assuming header to ignore otherwise start at 1
If Not dict.exists(arr(i, 1)) Then
dict.Add arr(i, 1), 1 '<==== if value not seen before add to dictionary with value of 1
Else
dict(arr(i, 1)) = dict(arr(i, 1)) + 1 ' <====== if seen before add 1 to the existing count
End If
Next i
End With
With Worksheets("Statistik")
.Range("A1") = "StudyBoard_ID"
.Range("B1") = "Count"
.Range("A2").Resize(dict.Count, 1) = Application.Transpose(dict.Keys)
.Range("B2").Resize(dict.Count, 1) = Application.Transpose(dict.Items)
End With
End Sub
This question already has answers here:
Split cell values into multiple rows and keep other data
(5 answers)
Create new Excel rows based on column data
(4 answers)
Macro to TRANSPOSE comma delimited cell into rows and copy down adjacent cells [closed]
(1 answer)
Closed 5 years ago.
Good afternoon,
I am having a big issue in my quest to learn VBA. Currently, my data is (as below) in a structure that sometimes contains multiple serial numbers belonging to a single part.
I have a VBA macro that I wrote which imports this data and formats it appropriately for a separate program. However, I am working on a sub that will allow me to go through and separate these serial numbers that are delimited by a comma.
For example:
But, I want it to look like this:
I found some code on this site (Split Cells Into Multiple Rows using Vb Code) which has helped, but I am having trouble with it: Here is what I have
Sub SplitSerial()
Dim SN As String
Dim i As Integer
Dim numArray()
SN = ActiveCell.Value
numArray = Split(SN, " ")
For LBound(numArray) To UBound(numArray)
Cells(1, i + 1).Value = numArray(i)
MsgBox numArray(i)
Next i
End Sub
The problem is, this spreadsheet can get pretty large (5,000+) rows, so I don't know how to have it loop through the column, and if it has a ",', split the serial numbers but copy the values from the remaining cells.
Any guidance, advice, or coaching would be greatly appreciated. I am trying very hard to learn VBA.
Try this, which uses arrays so should speed things up. Have added some comments to briefly explain what the code is doing.
Sub x()
Dim v, vOut(), i As Long, j As Long, k As Long, w
v = Sheet1.Range("A1").CurrentRegion.Value 'assumes starting data in A1 of sheet1
ReDim vOut(1 To UBound(v, 1) * 10, 1 To 3) 'output array, assumes no more than 10 serial numbers for each part
For i = LBound(v, 1) To UBound(v, 1)
w = Split(v(i, 2), ",") 'split serial number by comma
For j = LBound(w) To UBound(w) 'for each serial number
k = k + 1
vOut(k, 1) = v(i, 1) 'repeat part number
vOut(k, 2) = w(j) 'add particular serial number
vOut(k, 3) = v(i, 3) 'repeat price
Next j
Next i
Sheet2.Range("A1").Resize(k, 3) = vOut 'output to A1 of sheet2.
End Sub
I am trying to write a macro to loop through a spreadsheet, and on each row, concatenate three values (from different columns) into a single value (integer), and result that in another column on the same row. Then, increment from that number, based on the number from a different value in the column. Each iteration of this (including the first one) should copy the first column's value from that row, so that each increment reflects the same information in the newly created output.
Here's an example of the input data:
B2, C2, and D2 should all be concatenated, resulting in the number 5555551000, and that should be placed in cell I2. A2 should be copied to H2, as I2's location identifier. I2 should then be incremented based on the value of F2 (in this case, 10 times), and those results should be iterated under I2 starting at I3, with A2's value to the left of each output's cell, in the corresponding H column.
Here's an example of the output on the same sheet:
Once the output completes for expanding the first range of numbers, the loop continues to the next row and repeats the process.
I took a stab at this by setting the starting point, then doing a for loop with row.Count and inside of this, doing a Do While loop and breaking the loop based on the DID integer. I'm not having much success and perhaps it has to do with the way I'm using ActiveCell to try to move around during the iterations.
Any suggestions would be appreciated. I'm not allowed to embed pictures yet, thus the external links to the examples.
Like others have pointed out, its a lot easier to understand and troubleshoot what you're trying to do when you post the code, but I took a stab at it and came up with the following- quick note, this sub takes place on 2 different sheets (the source sheet, and then the resulting output sheet). If you really need it on the same sheet then I guess you could output the data right on top of the old data.
Public Sub sampleSub()
Dim sourceWS As Worksheet
Dim sourceData() As Variable
Dim outputRange As Range
Dim outputArr() As Variable
Dim readCounter As Long
Dim writeCounter As Long
Dim iterationCounter As Long
Set sourceWS = ThisWorkbook.Sheets(1)
sourceData = sourceWS.Range("A2:F4").Value2 'Read in source data
'Redim outout array with enough rows to be able to store each iteration (column F => 10 + 120 + 1000...)
ReDim outputArr(1 To Application.WorksheetFunction.Sum(sourceWS.Range("F2:F4")), 1 To 9)
For readCounter = 1 To UBound(sourceData, 1) 'Loop through each row of source data
For iterationCounter = 0 To sourceData(readCounter, 6) - 1 'Iterates to # in source data column F
writeCounter = writeCounter + 1
outputArr(writeCounter, 1) = sourceData(readCounter, 1) 'Write source data column A to output column A
outputArr(writeCounter, 2) = sourceData(readCounter, 2) 'Write source data column B to output column B
outputArr(writeCounter, 3) = sourceData(readCounter, 3) 'Write source data column C to output column C
outputArr(writeCounter, 4) = sourceData(readCounter, 4) 'Write source data column D to output column D
outputArr(writeCounter, 5) = sourceData(readCounter, 5) 'Write source data column E to output column E
outputArr(writeCounter, 6) = sourceData(readCounter, 6) 'Write source data column F to output column F
outputArr(writeCounter, 7) = sourceData(readCounter, 7) 'Write source data column G to output column G
outputArr(writeCounter, 8) = sourceData(readCounter, 1) 'Write source data column A to output column H
'Concatonate source data columns B, C & D and then adds iteration counter
outputArr(writeCounter, 9) = CLng(sourceData(readCounter, 2) & sourceData(readCounter, 3) & sourceData(readCounter, 4)) + iterationCounter
Next
Next
'User selects target range and then data is outputted
Set outputRange = Application.InputBox("Select target for output:", Type:=8)
outputRange.Resize(UBound(outputArr, 1), UBound(outputArr, 2)) = outputArr
End Sub
Hope this helps,
TheSilkCode
I am putting together some VBA code which i think needs a loop. Loops are often my biggest weakness with VBA and I need some assistance.
I have a text file which i import into an excel spreadsheet. The length of how many columns and rows and down will vary day to day.
For example today's file might have data in columns A - H, tomorrow it might be A : P. Each typical row count will be around the 200 mark, so not to long.
In essence im trying to make one long list in column A from all the data spread over multiple columns.
Im looking for a loop that checks if the column has data in it, if it does it then copies the data into the bottom of the data in column A.
So for illustration purposes say the data goes out to column G, it will copy B1, xl down, find the first empty row in A and paste, then do the same for C, stopping after column G.
I hope I’ve been clear when writing this.
Thanks in advance
Matt
You first want to loop over all columns. So a FOR loop from column B to LastColumn (which there is a function for.) Then you want to loop through all rows within that column to find the first empty row, and then substract one to arrive at the last column with data.
If Cells(row,col) = "" Then
LastRowCopy = row -1
Then you want to copy everything to A1, and keep track of the last row you posted in. So you want to have a variable that counts. Something like:
LastRowPaste = LastRowPaste + row
I could write the code for it, but perhaps you learn more by figuring it out yourself.
Edit: Also perhaps an interesting read on finding last rows and or columns is this: http://www.rondebruin.nl/win/s9/win005.htm
Edit2: You could ofcourse also use the same for finding the last column as the method I used for finding the last row. Then you just loop through the columns and see if:
If Cells(1, col) = "" Then
LastCol = col -1
Edit3:
I wrote out the entire code:
Sub copypaste()
Dim LastRowCopy As String
Dim LastRowPaste As String
Dim LastCol As String
Dim col As Integer
Dim row As Integer
LastCol = ActiveSheet.UsedRange.Columns.Count
LastRowCopy = ActiveSheet.UsedRange.Rows.Count
LastRowPaste = ActiveSheet.UsedRange.Rows.Count
For row = 1 to LastRowPaste
If Cells(row, 1) = "" Then
LastRowPaste = row
Exit For
End if
Next row
For col = 2 To LastCol
If Application.WorksheetFunction.CountA(Columns(col)) = 0 Then
LastCol = col -1
End If
Next col
For col = 2 To LastCol
For row = 1 To LastRowCopy
If Not Cells(row, col) = "" Then
Cells(LastRowPaste, 1) = Cells(row, col)
LastRowPaste = LastRowPaste + 1
End If
Next row
Next col
End Sub
Ok I have tried these and grasped some view on variants and I have written these code
Sub main()
Dim Vary As Variant
Vary = Sheet1.Range("A1:D11").Value
For i = 1 To UBound(Vary)
For j = i + 1 To UBound(Vary)
If Vary(i, 1) = Vary(j, 1) Then
'I should delete the vary(j,1) element from vary
'in excel sheet we use selection.entirerow.delete
End If
Next j
Next i
End Sub
This is the sample I tried
A B C D
1 somevalues in BCD columns
2
3
1
Now Delete the 4th row don think I'm working for unique records I'm just learning stuff to do and while I was learning variant I am stuck at this point deleting a complete row stored in variant
I have stored (A1:D11).value in variant
Now how can I delete the A6 element or row in variant so that I can avoid it while I copy the variant to some other sheet?
Can I also delete the C AND B columns in variant so that when i do transpose it wont copy the C and B columns?
I don't know what exactly a variant is - I was thinking to take a set of range and do operations like what we do for an excel sheet then take that variant and transpose it back to sheet.
Is that the right way of thinking or did I misunderstand the use of variants?
`variant(k,1)=text(x)` some array shows mismatch ? whats wrong?
If you are planning on using a varray to look at cells in each row to decide if you should delete the row or not, you should loop through your varray backwards, the same way you would if you did a for loop through the cell range. Since you are starting on row 1, the variable i will always equal the row number the element was located on, so you can use that to delete the proper row.
Here's a sample (more simple than what you are trying to do, though) that will delete each row in which the cells in columns A and B are the same.
Sub test()
Dim varray As Variant
varray = Range("A1:B11").Value
For i = UBound(varray, 1) To 1 Step -1
If varray(i, 1) = varray(i, 2) Then
Cells(i, 1).EntireRow.Delete
End If
Next
End Sub
Notes of interest:
UBound(varray, 1) gives the count of the rows
UBound(varray, 2) gives the count of the columns
One workaround without a second array is to introduce a deliberate error into an element you want to replace, then use SpecialCells to delete the cell after dumping the variant array back over the range. This sample introduces an error into the array position corresponding to A6 (outside the loop as its an example), then when the range is dumped to E1, the SpecialCell error removal shifts F6:H6 into E6:G6. ie
pls save before testing - this code will overwrite E6:H11 in the first worksheet
Sub main()
Dim Vary As Variant
Dim rng1 As Range
Set rng1 = Sheets(1).Range("A1:D11")
Set rng2 = rng1.Offset(0, 4)
Vary = rng1.Value2
For i = 1 To UBound(Vary)
For j = i + 1 To UBound(Vary)
'your test here
Next j
Next i
Vary(6, 1) = "=(1 / 0)"
With rng2
.Value2 = Vary
On Error Resume Next
.SpecialCells(xlFormulas, xlErrors).Delete xlToLeft
End With
End Sub