I have a cell with a string of different lengths. I want split them into individual cells with a length of, say, 3 characters.
A cell with ABCCBA should end up ABC CBA in 2 different cells.
While a cell with ABCDABCDAB should end up ABC DAB CDA B in 4 different cells.
Is there any convenient way to do this?
I was looking at
' Finding number of cells
Segments = WorksheetFunction.RoundUp(Len(Range("A1").Value) / 3, 0)
' Split base on character length
For n = 1 to Segments
Cells(2, n) = Range("A1").Characters(n, 3)
Next n
But it doesn't seem to work.
A simple macro to split the string in to 3 lettered strings and write into columns next to the data range
Sub Split()
Dim Checkcol As Integer
Dim currentRowValue As String
Dim rowCount As Integer
Dim splitval As Integer
Dim i As Integer, j As Integer
Checkcol = 1 'Denotes A column
rowCount = Cells(Rows.Count, Checkcol).End(xlUp).Row
For currentRow = 1 To rowCount
currentRowValue = Cells(currentRow, Checkcol).Value
splitval = Int(Len(currentRowValue) / 3) + 1 'Find the number of 3 letter strings
j = 0
For i = 1 To splitval 'Loop through each value and write in next columns
j = (i - 1) * 3 + 1
Cells(currentRow, Checkcol + i).Value = Mid(currentRowValue, j, 3)
Next
Next
End Sub
If you are comfortable with formulas, assuming your data is in Cell A2, and you want to implement the formula in Cell B2 and rightwards.
Formula in B2:
=MID($A2,(COLUMNS($B$2:B2)-1)*3+1,3)
Copy it down and across as much you need.
Related
this is my first time using VBA. My goal is to create a column of values that are the result of evaluating a function. Here is a simplified version of how I'm structuring my code.
Sub find_alpha()
Dim StartNumber As Integer
Dim EndNumber As Integer
Dim i As Integer
Dim alpha As Integer
EndNumber = 39
For alpha = 0 To 10
For StartNumber = 1 To EndNumber
For i = 0 To 38
Cells(StartNumber, "A").Value = Cells.Item(1, "B") * i * (1 - alpha)
Next i
Next StartNumber
Next alpha
End Sub
This doesn't work because it loops from 0 to 38 in only one cell, while I need it to actually move through and add the value to each cell. So the value at i=0, should go to A1, i=2 should go to A2, i=3 should go to A3, etc.
Is there a way to move through the loop in parallel to accomplish this?
Thank you!!
your question/aim isn't very clear so here are some possible blind shots:
place from cell "A1" down to a predefined rows number (EndNumber) the result of multiplying cell "B1" value by a number from 0 to (currentRowIndex- 1) * (1 - alpha), where currentRowIndex is the row index of the current cell in column "A" being written and alpha varies from 0 to 10 (...)
then you'd go:
Option Explicit
Sub find_alpha1()
Dim StartNumber As Long
Dim EndNumber As Long
Dim i As Long
Dim alpha As Long
StartNumber = 1
EndNumber = 39
For alpha = 0 To 10
For i = StartNumber To EndNumber
Cells(i, "A").value = Cells.item(1, "B") * (i - 1) * (1 - alpha)
Next i
Next alpha
End Sub
the same code could be rewritten as follows:
Option Explicit
Sub find_alpha2()
Dim EndNumber As Long
Dim alpha As Long
EndNumber = 39
For alpha = 0 To 10
With Range("A1").Resize(EndNumber)
.FormulaR1C1 = "=R1C2*(ROW()-1)*(1-" & alpha & ")"
.Value=.Value '<--| get rid of the formula and leave values only
End With
Next alpha
End Sub
but there would be the issue that those column "A" cells would be rewritten at every For alpha = 0 To 10 loop ... (see below)
place in columns starting from "A" rightwards from row 1 to a predefined rows number (EndNumber) the results of multiplying cell "B1" value by a number from 0 to (currentRowIndex- 1) * (1 - alpha), where currentRowIndex is the row index of the current cell in current column being written and with columns shifting rightwards at every alpha loop from 0 to 10
for such a task you actually need to write cells from row 2 downwards in order not to overwrite cell "B1"
then you'd go:
Option Explicit
Sub find_alpha3()
Dim EndNumber As Long
Dim alpha As Long
EndNumber = 39
For alpha = 0 To 10
With Range("A2").Offset(, alpha).Resize(EndNumber)
.FormulaR1C1 = "=R1C2*(ROW()-2)*(1-" & alpha & ")"
.value = .value '<--| get rid of the formula and leave values only
End With
Next alpha
End Sub
If not 1 or 2 then what?
Hello all so I am very new to VBA but have take some beginner classes in Java and HTML so I Almost know what I am doing.
So I have a cell in which I want to split based on a comma (,)
and I want to count the number of occurrences of a certain Character and then display that result in another cell. Doing this while going down a column of these rows in that single column.
ex: y,y,y,n,y = in cell D6 : 4
Below is the bit of code I have generated with the little bit of information I have learned about VBA online.
I have also seen this bit of code but it get very complex very fast (link) so if someone could explain that one instead I would be very grateful.
(I tried to comment on the answer but dont have enough rep to do so)
And please when giving the answer try to explain the methods, I dont have an understanding of what each does, being both new to programming and VBA so in regaurds to your replies see if I am able to figure it out with a bit of a push.
Private Sub CommandButton15_Click()
Dim Number As String
Dim Yoccur As Integer
Dim Noccur As Integer
Dim Notapp As Integer
Dim length As Integer
Dim current As String
Dim i As Integer
Dim Row As Integer
Do While Row < 84
For i = 1 To length
'parse data into a array here
'tempArr = Split(X(lngRow, 2), ",")
' would that work if I tried to split based on the comma?
If current = "y" Then Yoccur = Yoccur + 1
If current = "n" Then Noccur = Noccur + 1
If current = "n/a" Then Notapp = Notapp + 1
Next i
Wend
Range("d45").Value = Yoccur
Range("d46").Value = Noccur
Range("d47").Value = Notapp
End Sub
The code below
Sets a range from D6 to the last used cell in column D
It joins all the values in this range together into a single string (strV) using Join
It dumps the number of y values in A1 by subtracting the length of the string with all y characters removed from the length of the unaltered string (more detailed explanation below)
[a1] = Len(strV) - Len(Replace(strV, "y", vbNullString)) puts the number of y values in A1
[a3] = (Len(strV) - Len(Replace(strV, "n/a", vbNullString))) / 3 puts the number of n/a values in A2 (the /3 is needed to count removing the 3 character length n/a as one replacement)
[a2].Value = Len(strV) - Len(Replace(strV, "n", vbNullString)) - [a3].Value] counts the number of n values - the number of n/a values in A3 (as n/a contains a n)
code
Sub QuickDump()
Dim rng1 As Range
Dim strV As String
Set rng1 = Range([d6], Cells(Rows.Count, "d").End(xlUp))
strV = Join(Application.Transpose(rng1.Value), ",")
d = Filter(Application.Transpose(rng1.Value), "y", True, vbTextCompare)
[a1] = Len(strV) - Len(Replace(strV, "y", vbNullString))
[a3] = (Len(strV) - Len(Replace(strV, "n/a", vbNullString))) / 3
[a2].Value = Len(strV) - Len(Replace(strV, "n", vbNullString)) - [a3].Value
End Sub
The following code should help. Note the assumptions:
Your input is located in column A of the sheet, across multiple rows with no spaces between them and starts at row 1.
The output column for "y" is D, for "n" is E and for "n/a" is F.
Private Sub CommandButton15_Click()
Dim lastRow As Long
Dim row As Long
Dim c As Range
Dim arr() As String
Dim s As Variant
Dim sumY As Long
Dim sumN As Long
Dim sumNA As Long
' This is the last row of your input in column A.
lastRow = ActiveSheet.Cells(ActiveSheet.Rows.Count, 1).End(xlUp).row
For row = 1 To lastRow ' Loop all used rows
sumY = 0 ' Reset for every loop.
sumN = 0
sumNA = 0
Set c = Cells(row, 1)
arr = Split(c, ",") ' Split the value in the cell (row, 1) on comma.
' For each string in the split array, do lower-case comparisons
' for "y", "n" and "n/a" and increment appropriate counters.
For Each s In arr
If LCase(s) = "y" Then
sumY = sumY + 1
ElseIf LCase(s) = "n" Then
sumN = sumN + 1
ElseIf LCase(s) = "n/a" Then
sumNA = sumNA + 1
Else
MsgBox "Unknown value!" ' Sanity test if something is wrong with the input.
End If
Next
' Assign the sums of "y", "n" and "n/a" to columns 4, 5 and 6 (D, E and F).
Cells(row, 4).Value = sumY
Cells(row, 5).Value = sumN
Cells(row, 6).Value = sumNA
Next row
End Sub
I'm sure it's not "perfect" (it's very late -- or early -- here!) but it should work and it should at least give you some ideas on how to proceed from here.
Let me know if you need me to explain anything that's not clear.
UPDATE
Given the same assumptions as above (you can change column A to column C by replacing 1 to 3 in the column indexing of the code) and your comment about linebreaks if I understood it correctly, the following code will now not only calculate the values for each row but will instead count the occurrences of "y", "n" and "n/a" across all rows and will put the results in cell D1 for "y", E1 for "n" and F1 for "n/a".
Private Sub CommandButton15_Click()
Dim lastRow As Long
Dim row As Long
Dim c As Range
Dim arr() As String
Dim s As Variant
Dim sumY As Long
Dim sumN As Long
Dim sumNA As Long
' This is the last row of your input in column A.
lastRow = ActiveSheet.Cells(ActiveSheet.Rows.Count, 1).End(xlUp).row
For row = 1 To lastRow ' Loop all used rows
Set c = Cells(row, 1)
arr = Split(c, ",") ' Split the value in the cell (row, 1) on comma.
' For each string in the split array, do lower-case comparisons
' for "y", "n" and "n/a" and increment appropriate counters.
For Each s In arr
If LCase(s) = "y" Then
sumY = sumY + 1
ElseIf LCase(s) = "n" Then
sumN = sumN + 1
ElseIf LCase(s) = "n/a" Then
sumNA = sumNA + 1
Else
MsgBox "Unknown value!" ' Sanity test if something is wrong with the input.
End If
Next
Next row
' Assign the sums of "y", "n" and "n/a" to columns 4, 5 and 6 (D, E and F).
Cells(1, 4).Value = sumY
Cells(1, 5).Value = sumN
Cells(1, 6).Value = sumNA
End Sub
I am looping through each cell in a column and performing split operation on the text(delimited by ,) for each cell. I have the result in an array.And I am placing it in a range of cells.When ever next cell value is fetched and split operation is carried , new value overwrites the previous result. How can i find the next empty cell and place the array content with out overwriting.
Range("A1:A" & UBound(x) + 1) = WorksheetFunction.Transpose(x)
I have texts separated by ,
example A,B,C,D in column E2
B,M,C... in E3 and so on till 36000(value may increase)
Dim txt As String
Dim x As Variant
Dim i As Long
Dim lrow As Double
lrow = Sheet1.UsedRange.Rows.Count
For j = 1 To lrow
txt = Sheet1.Range("m2").Offset(j - 1, 0)
x = Split(txt, ",")
For i = 0 To UBound(x)
'Debug.Print x(i)
Range("A1:A" & UBound(x) + 1) = WorksheetFunction.Transpose(x) 'How can i change this line to find next empty cell and palce the result in it
Next i
Next j
The above code will loop through each row and split the text. But every time the result is overwritten. How can i find next empty cell and place the result in it?
Please try this, This will work for M2=abc,BCD,Xyz,pdt. If M3=zse,ssd,vbd will come it will over write the value A1 to A(j) Value. So update it accordingly.
Dim i As Integer
Dim M2 As String
Dim spltStore As Variant
Public Sub page_load()
M2="abc,BCD,Xyz,pdt"
spltStore = Split(M2, ",")
j = 1
For i = 0 To UBound(spltStore)
Sheet1.Range("A" & j).Value = spltStore(i)
Debug.Print spltStore(i)
j = j + 1
Next i
End Sub
Hope this will work for you.
Try this:
j=1
i=1
Do While IsEmpty(Worksheets("test").Cells(j, i)) = False
'<do your stuff>
j = j + 1
Loop
j and i are cell coordinates. This loop will go through all the non-empty cells and stop on an empty one.
I am working on a code that is supposed to get the values from columns that correspond to the last three rows of a table I created. It needs to be under this form because the numbers will be random.
I have a table in the first excel sheet with different values. I calculate how many rows and columns there are.
Then I get the last three values from the second sheet, belonging to the column Index. I will use these indexes in order to construct a code that will obtain these indexes and indentify the columns they correspond to in the first excel sheet. THen, I want it to extract these values for me.
The problem is it gets the three FIRST values not last
How can I fix this?
Option Explicit
Option Base 1
Sub ThreeBest()
Dim i As Integer, j As Integer, N As Integer
Dim Valeurs As Integer
Dim nb_Cells As Integer
Dim nb_Actions As Integer
nb_Cells = Worksheets("Actions").Cells(Rows.Count, 2).End(xlUp).Row - 1
nb_Actions = Worksheets("Actions").Cells(1, Columns.Count).End(xlToLeft).Column - 1
N = 3 'We want to choose the three last ones
ReDim ValeursAction(nb_Cells) As Variant
For i = 1 To N
Valeurs = Worksheets("Performance").Cells(nb_Actions + 7 - (i - 1), 9).Value
'I place the value from the column corresponding to Valeurs in Performance
For j = 1 To nb_Cells
ValeursAction(j) = Worksheets("Actions").Cells(j + 1, Valeurs + 1)
With Sheets("Performance")
.Cells(5 + j, 5 - i) = ValeursAction(j)
End With
Next j
Next i
End Sub
Unless I completely misunderstood your request, I think that you need to use xlToRight and xlDown to find the last columns and rows respectively.
Try this:
Option Explicit
Option Base 1
Sub ThreeBest()
Dim i As Integer, j As Integer, N As Integer
Dim Valeurs As Integer
Dim nb_Cells As Integer
Dim nb_Actions As Integer
nb_Cells = Worksheets("Actions").Cells(Rows.Count, 2).End(xlDown).Row - 1
nb_Actions = Worksheets("Actions").Cells(1, Columns.Count).End(xlToRight).Column - 1
N = 3 'We want to choose the three last ones
ReDim ValeursAction(nb_Cells) As Variant
For i = 1 To N
Valeurs = Worksheets("Performance").Cells(nb_Actions + 7 - (i - 1), 9).Value
'I place the value from the column corresponding to Valeurs in Performance
For j = 1 To nb_Cells
ValeursAction(j) = Worksheets("Actions").Cells(j + 1, Valeurs + 1)
With Sheets("Performance")
.Cells(5 + j, 5 - i) = ValeursAction(j)
End With
Next j
Next i
End Sub
I am receiving a large file 500k+ lines but all the content is in column A. I need to run a macro that will transpose the data into matrix form but will only create a new row when it finds "KEY*" in the ActiveCell. For example:
| KEY 4759839 | asljhk | 35049 | | sklahksdjf|
| KEY 359 | skj | 487 |y| 2985789 |
The above data in my file would originally look like this in column A:
KEY 4759839
asljhk
35049
sklahksdjf
KEY 359
skj
487
y
2985789
Considerations:
Blank cells need to be transposed as well, so the macro cant stop based on emptyCell
The number of cells between KEY's is not constant so it actually needs to read the cell to know if it should create a new row
It can either stop based on say 20 empty cells in a row or prompt for a max row number
(Optional) It would be nice if there was some sort of visual indicator for the last item in a row so that its possible to tell if the last item(s) were blank cells
I searched around and found a macro that had the same general theme but it went based on every 6 lines and I did not know enough to try to modify it for my case. But in case it helps here it is:
Sub kTest()
Dim a, w(), i As Long, j As Long, c As Integer
a = Range([a1], [a500000].End(xlUp))
ReDim w(1 To UBound(a, 1), 1 To 6)
j = 1
For i = 1 To UBound(a, 1)
c = 1 + (i - 1) Mod 6: w(j, c) = a(i, 1)
If c = 6 Then j = j + 1
Next i
[c1].Resize(j, 6) = w
End Sub
I would greatly appreciate any help you can give me!
This works with the sample data you provided in your question - it outputs the result in a table starting in B1. It runs in less than one second for 500k rows on my machine.
Sub kTest()
Dim originalData As Variant
Dim result As Variant
Dim i As Long
Dim j As Long
Dim k As Long
Dim countKeys As Long
Dim countColumns As Long
Dim maxColumns As Long
originalData = Range([a1], [a500000].End(xlUp))
countKeys = 0
maxColumns = 0
'Calculate the number of lines and columns that will be required
For i = LBound(originalData, 1) To UBound(originalData, 1)
If Left(originalData(i, 1), 3) = "KEY" Then
countKeys = countKeys + 1
maxColumns = IIf(countColumns > maxColumns, countColumns, maxColumns)
countColumns = 1
Else
countColumns = countColumns + 1
End If
Next i
'Create the resulting array
ReDim result(1 To countKeys, 1 To maxColumns) As Variant
j = 0
k = 1
For i = LBound(originalData, 1) To UBound(originalData, 1)
If Left(originalData(i, 1), 3) = "KEY" Then
j = j + 1
k = 1
Else
k = k + 1
End If
result(j, k) = originalData(i, 1)
Next i
With ActiveSheet
.Cells(1, 2).Resize(UBound(result, 1), UBound(result, 2)) = result
End With
End Sub
Tested and works:
Sub test()
Row = 0
col = 1
'Find the last not empty cell by selecting the bottom cell and moving up
Max = Range("A650000").End(xlUp).Row 'Or whatever the last allowed row number is
'loop through the data
For i = 1 To Max
'Check if the left 3 characters of the cell are "KEY" and start a new row if they are
If (Left(Range("A" & i).Value, 3) = "KEY") Then
Row = Row + 1
col = 1
End If
Cells(Row, col).Value = Range("A" & i).Value
If (i > Row) Then
Range("A" & i).Value = ""
End If
col = col + 1
Next i
End Sub