I'm trying to get Excel to list every variation of a certain value.
If A1= ABC1904
& A2= ABC1910
I'd like column B to list.
ABC1904
ABC1905
ABC1906
ABC1907
ABC1908
ABC1909
ABC1910
This is the best I could do w/ a purely formula solution:
=LEFT(A$1,3) & MID(A$1,MIN(FIND({0,1,2,3,4,5,6,7,8,9},A$1&"0123456789")),LEN(A$1))+MIN(RIGHT($A$2,1)+0,ROWS(A$1:A1)-1)
It leaves a bit to be desired because you'll have a bunch of duplicates if you drag the formula too far down.
If you're not opposed to a VBA solution, you could give this a go:
Sub VariationOfValue()
Dim startNumber As Long, _
endNumber As Long, _
counter As Long
Dim leadingString As String
With Application
.ScreenUpdating = False
.Calculation = xlCalculationManual
End With
counter = 1
With Sheet1
leadingString = Left(Sheet1.Range("A1").Value, 3)
startNumber = Evaluate("=MID(A$1,MIN(FIND({0,1,2,3,4,5,6,7,8,9},A$1&""0123456789"")),LEN(A$1))") + 0
endNumber = Evaluate("=MID(A$2,MIN(FIND({0,1,2,3,4,5,6,7,8,9},A$2&""0123456789"")),LEN(A$2))") + 0
Do While startNumber <= endNumber
.Range("B" & counter).Value = leadingString & startNumber
counter = counter + 1
startNumber = startNumber + 1
Loop
End With
With Application
.ScreenUpdating = True
.Calculation = xlCalculationAutomatic
End With
End Sub
Does basically the same thing, but only until the last number is reached. Either way, hope one or both of these helps out a bit.
If you are willing to have a few columns to achieve this then it is really not very difficult.
Col A is your starting data. [ABC1904 and ABC1910}
Col B contains equations =VALUE(RIGHT(A1,LEN(A1)-3)) which gives the numeric part of the strings. [1904 and 1910]
Col C contains equations =IF(OR(C2=B$2,C2=""),"",C2+1) - except C1 which is just =b1
- this gives the series of numbers you want {1904 to 1910]
Col D contains equations =IF(C1="","",LEFT(A$1,3)&C1)
- this puts the text back on the front of the numbers [ABC1904 to ABC1910]
..this would be clearer with a screenshot but I apparently do not have enough reputation to post one
Related
I have an Excel project which has a few thousand rows containing strings which need sorting out.
Typically one cell in each row should have a six digit number 123456 but many are 123456/123456/234567 etc. which need to have the / deleted and then be separated onto individual rows. There is other information in the surrounding columns which needs to stay with these six digit numbers.
I decided to approach this by firstly making copies of the rows the appropriate number of times and then deleting the surplus information
This code below deals with the copying part and it works.. but it's really slow. Is there a quicker way to achieve what I'm trying to do?
Thanks for any help.
Chris
Sub Copy_extra_rows()
Application.ScreenUpdating = False
s = 2
Do Until s = Range("N20000").End(xlUp).Row
'checks for / in Mod list
If InStr(1, Range("N" & s), "/") Then
'determines number of /
x = Len(Range("N" & s)) - Len(Replace(Range("N" & s), "/", ""))
'loops x times and copies new row
For a = 1 To x
Range("J" & s & ":O" & s).Select
Selection.Copy
Range("J" & s + 1).Select
Selection.Insert Shift:=xlDown
s = s + 1
Next a
Else
End If
s = s + 1
Loop
End Sub
I would have approached this differently to optimize the process and improve the overall efficiency of code.
Firstly, I would load the entire column into an array. This way it's always faster to access the elements of that array rather then referring Cells() multiple times in loops. Working with objects in memory is much faster because your client doesn't need to for example update the UI. Generally, arrays big O is O(1) which means you instantly can access an object/data stored at a specific index.
Let's consider an SSCCE.
Then the code (*Note: I have added comments in the code in the right places, hopefully that helps you understand what is going on)
Sub Main()
Dim columnArray As Variant
' create an array from Range starting at L2 to the last row filled with data
columnArray = Range("N2:N" & Range("N" & Rows.Count).End(xlUp).Row)
Dim c As New Collection
' add separate 6 digit numbers to the collection as separate items
' iterate the columnArray array and split the contents
Dim element As Variant
For Each element In columnArray
If NeedSplitting(element) Then
Dim splittedElements As Variant
splittedElements = Split(element, "/")
Dim splittedElement As Variant
For Each splittedElement In splittedElements
c.Add splittedElement
Next
Else
c.Add element
End If
Next
' print the collection to column Q
PrintToColumn c, "Q"
End Sub
Private Sub PrintToColumn(c As Collection, ByVal toColumn As String)
Application.ScreenUpdating = False
' clear the column before printing
Columns(toColumn).ClearContents
' iterate collection and print each item on a new row in the specified column
Dim element As Variant
For Each element In c
Range(toColumn & Range(toColumn & Rows.Count).End(xlUp).Row + 1) = element
Next
Application.ScreenUpdating = True
End Sub
Private Function NeedSplitting(cell As Variant) As Boolean
' returns true if the cell needs splitting
If UBound(Split(cell, "/")) > 0 Then
NeedSplitting = True
End If
End Function
After running the code all your numbers should appear as separate elements in column Q
NOTE: Why use a Collection?
Collections in VBA are dynamic. It means you don't have to know the size of a collection in order to use it - unlike arrays. You can re-dim your array multiple times to increase its size but that's rather considered a bad practice. You can add nearly as many items to a Collection as you want with a simple Collection.Add method and you don't have to worry about increasing the size manually - it's all done for you automatically. In this scenario the processing happens in memory so it should be much quicker then replacing cells contents inside a loop.
Try this:
Dim s As Integer
Dim splitted_array() As String
s = 2 'Assuming data starts at row 2
Do Until Range("N" & s).Value = vbNullString Or s >= Rows.Count
'Split the array
splitted_array = Split(Range("N" & s).Value, "/")
If UBound(splitted_array) > 0 Then
'Set the first value on the first row
Range("N" & s).Value = splitted_array(0)
For i = 1 To UBound(splitted_array)
'Add subsequent rows
Rows(s + i).Insert xlDown
Range("J" & s + i & ":O" & s + i).Value = Range("J" & s & ":O" & s).Value
Range("N" & s + i).Value = splitted_array(i)
Next
End If
s = s + 1 + UBound(splitted_array)
Loop
This code turns this:
into this:
I have a set of VBA codes which work really perfectly with around of 20 000 x 16 cells.
However, I need to use the codes with max 80 000 x 16 cells.
I have identified two types of codes which run really slow:
c = 2 'this is the first row where your data will output
d = 2 'this is the first row where you want to check for data
Application.ScreenUpdating = False
Do Until Range("A" & c) = "" 'This will loop until column U is empty, set the column to whatever you want
'but it cannot have blanks in it, or it will stop looping. Choose a column that is
'always going to have data in it.
ws1.Range("U" & d).FormulaR1C1 = "=RC[-20] & RIGHT(""0000"" & RC[-14], 6)"
c = c + 1 'Advances a and b when there is a matching case
d = d + 1
Loop
Application.ScreenUpdating = True
End Sub
Sub OpenValue()
Dim l As Integer
Dim k As Integer
Dim m As Integer
m = Sheets("Input").Range("AC:AC").End(xlDown).Row
For l = 2 To m
If Range("AC" & l) = "Delievered" Then
Range("AD" & l) = 0
ElseIf Range("AC" & l) = "Cancelled" Then
Range("AD" & l) = 0
Else
Range("AD" & l) = Val(Range("Z" & l)) * Val(Range("J" & l))
End If
Next
End Sub
What can I do to poptimize them ....
The link provided by #GSerg is an awesome way to cut the running time of your script down. I found myself using:
Application.ScreenUpdating set to False
Application.Calculation set to xlCalculationManual
Application.EnableEvents set to False
Application.DisplayAlerts set to False
so often that I combined them into a single public subroutine. #Garys-Student provided the inspiration:
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'INPUT : True or False (i.e. fast or slow)
'DESCRIPTION : this sub turns off screen updating and alarms then
' sets calculations to manual
'
Public Sub GoFast(OnOrOff As Boolean)
Dim CalcMode As XlCalculation
CalcMode = Application.Calculation
With Application
.ScreenUpdating = Not OnOrOff
.EnableEvents = Not OnOrOff
.DisplayAlerts = Not OnOrOff
If OnOrOff Then
.Calculation = xlCalculationManual
Else
.Calculation = CalcMode
End If
End With
End Sub
In practice, you can now add the one-liner:
Call GoFast(True)
at the beginning of your script as part of the setup, then add:
Call GoFast(False)
at the end of your script as part of the teardown. Modify as you see fit!
The Do Until can be replaced with a one liner:
ws1.Range("A2", ws1.Range("A2").End(xlDown)).Offset(0,20).FormulaR1C1 = _
"=RC[-20] & RIGHT(""0000"" & RC[-14], 6)"
Note that this will fail if A3 is empty. If you have headers in row 1 you can change the second A2 to A1.
For the other Sub I'm not sure if you are doing something special with Val but if not you could change it to something similar:
Sub OpenValue()
Dim r As Range
Set r = Sheets("Input").Range("AD2:AD" & Sheets("Input").Range("AC1").End(xlDown).Row)
With r
.FormulaR1C1 = "=IF(OR(RC[-1]=""Delivered"",RC[-1]=""Cancelled""),0,RC10*RC26"
'If you want these as values uncomment the following lines
'.Calculate
'.Copy
'.PasteSpecial xlPasteValues
End With
End Sub
Sprinkle Application stuff around if needed (Calculation, ScreenUpdating, DisplayAlerts, EnableEvents).
Why is this faster:
To put it simply, VBA and Excel have to open a 'channel' to communicate between each other and this costs some time. So looping through a Range and adding formulas one-by-one is much slower for large ranges than doing it all at once since you'll only open the 'channel' once.
Please be aware that I am working with a series of ~1000 line medical information databases. Due to the size of the databases, manual manipulation of the data is too time consuming. As such, I have attempted to learn VBA and code an Excel 2010 macro using VBA to help me accomplish parsing certain data. The desired output is to split certain characters from a provided string on each line of the database as follows:
99204 - OFFICE/OUTPATIENT VISIT, NEW
will need to be split into
Active Row Active Column = 99204 ActiveRow Active Column+3 = OFFICE/OUTPATIENT VISIT, NEW
I have researched this topic using Walkenbach's "Excel 2013: Power Programming with VBA" and a fair amount of web resources, including this awesome site, but have been unable to develop a fully-workable solution using VBA in Excel. The code for my current macro is:
Sub EasySplit()
Dim text As String
Dim a As Integer
Dim name As Variant
text = ActiveCell.Value
name = Split(text, "-", 2)
For a = 0 To 1
Cells(1, a + 3).Value = Trim(name(a))
Next a
End Sub
The code uses the "-" character as a delimiter to split the input string into two substrings (I have limited the output strings to 2, as there exists in some input strings multiple "-" characters). I have trimmed the second string output to remove leading spaces.
The trouble that I am having is that the output is being presented at the top of the activesheet, instead of on the activerow.
Thank you in advance for any help. I have been working on this for 2 days and although I have made some progress, I feel that I have reached an impasse. I think that the issue is somewhere in the
Cells(1, a + 3).Value = Trim(name(a))
code, specifically with "Cells()".
Thank you Conrad Frix!
Yah.. funny enough. Just after I post I have a brainstorm.. and modify the code to read:
Sub EasySplit()
Dim text As String
Dim a As Integer
Dim name As Variant
text = ActiveCell.Value
name = Split(text, "-", 2)
For a = 0 To 1
ActiveCell.Offset(0, 3 + a).Value = Trim(name(a))
Next a
End Sub
Not quite the colkumn1,column4 output that I want (it outputs to column3,column4), but it will work for my purpose.
Now I need to incorporate a loop so that the code runs on each successive cell in the column (downwards, step 1) skipping all bolded cells, until it hits an empty cell.
Modified answer to modified request.
This will start on row 1 and continue until a blank cell is found in column A. If you would like to start on a different row, perhaps row 2 if you have headers, change the
i = 1
line to
i = 2
I added a check on the upper bound of our variant before doing the output writes, in case the macro is run again on already formatted cells. (Does nothing instead of erroring out)
Sub EasySplit()
Dim initialText As String
Dim i As Double
Dim name As Variant
i = 1
Do While Trim(Cells(i, 1)) <> ""
If Not Cells(i, 1).Font.Bold Then
initialText = Cells(i, 1).text
name = Split(initialText, "-", 2)
If Not UBound(name) < 1 Then
Cells(i, 1) = Trim(name(0))
Cells(i, 4) = Trim(name(1))
End If
End If
i = i + 1
Loop
End Sub
just add a variable to keep track of the active row and then use that in place of the constant 1.
e.g.
Dim iRow as Integer = ActiveCell.Row
For a = 0 To 1
Cells(iRow , a + 3).Value = Trim(name(a))
Next a
Alternate method utilizing TextToColumns. This code also avoids using a loop, making it more efficient and much faster. Comments have been added to assist with understanding the code.
EDIT: I have expanded the code to make it more versatile by using a temp worksheet. You can then output the two columns to wherever you'd like. As stated in your original question, the output is now to columns 1 and 4.
Sub tgr()
Const DataCol As String = "A" 'Change to the correct column letter
Const HeaderRow As Long = 1 'Change to be the correct header row
Dim rngOriginal As Range 'Use this variable to capture your original data
'Capture the original data, starting in Data column and the header row + 1
Set rngOriginal = Range(DataCol & HeaderRow + 1, Cells(Rows.Count, DataCol).End(xlUp))
If rngOriginal.Row < HeaderRow + 1 Then Exit Sub 'No data
'We will be using a temp worksheet, and to avoid a prompt when we delete the temp worksheet we turn off alerts
'We also turn off screenupdating to prevent "screen flickering"
Application.DisplayAlerts = False
Application.ScreenUpdating = False
'Move the original data to a temp worksheet to perform the split
'To avoid having leading/trailing spaces, replace all instances of " - " with simply "-"
'Lastly, move the split data to desired locations and remove the temp worksheet
With Sheets.Add.Range("A1").Resize(rngOriginal.Rows.Count)
.Value = rngOriginal.Value
.Replace " - ", "-"
.TextToColumns .Cells, xlDelimited, Other:=True, OtherChar:="-"
rngOriginal.Value = .Value
rngOriginal.Offset(, 3).Value = .Offset(, 1).Value
.Worksheet.Delete
End With
'Now that all operations have completed, turn alerts and screenupdating back on
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub
You can do this in a single shot without looping using the VBA equivalent of entering this formula, then taking values only
as a formula
=IF(NOT(ISERROR(FIND("-",A1))),RIGHT(A1,LEN(A1)-FIND("-",A1)-1 ),A1)
code
Sub Quicker()
Dim rng1 As Range
Set rng1 = Range([a1], Cells(Rows.Count, "A").End(xlUp))
With rng1.Offset(0, 3)
.FormulaR1C1 = "=IF(NOT(ISERROR(FIND(""-"",RC[-3]))),RIGHT(RC[-3],LEN(RC[-3])-FIND(""-"",RC[-3])-1 ),RC[-3])"
.Value = .Value
End With
End Sub
I will use an example to illustrate my question:
I have many tables which their lines quantity is different.
I want to pull down the function until the end of the table.
For example:
A B
1 =1*2 // <- this is the function that I want to pull
2
3
4
The output should be:
A B
1 =1*2
2 =2*2
3 =3*2
4 =4*2
It is important that the pull length is determined by the last cell at column A (in this case it is 4)
Please also note that the function may be changed either, this should work for any function.
Thank you,
Doron
Here is an example of a macro that will autofill the value from cell B1 to the end of the column to the left of it (in this case column A).
Sub AutoFill()
Dim FillFrom As Range
Set FillFrom = ActiveSheet.Range("B1")
FillFrom.AutoFill Destination:=Range(FillFrom.Address, FillFrom.Offset(0, -1).End(xlDown).Offset(0, 1).Address)
End Sub
Try This:
Public Sub DoWhatIWantYouToDo()
Dim lr As Integer, i As Integer
lr = Sheets("Sheet1").UsedRange.Rows.Count
For i = 2 To lr
Sheets("Sheet1").Range("B" & i).Formula = "=" & " A" & i & "*2"
Next
End Sub
this is my first time using the site, so forgive me for any inept explaining. I have a working macro to hide/unhide rows based on content of the rows, I just want it to be faster. Using a check box, when the box is checked, all rows with an "x" in column D get unhidden, those without an "x" get hidden. Same thing happens when it is unchecked, except it references column C, not D.
Right now, this code works. It's just a little slower than I'd like, since I'm sharing this with a bunch of people. Any ideas for how to speed it up? I'm pretty darn new to VB (the internet is astoundingly wise and a good teacher), but that doesn't matter. I already improved the code - before it selected each row, then referenced the column, and it was awful. Any ideas to speed it up (preferably without moving the screen) would be great.
Thanks so much folks,
DS
Sub NewLuxCheck()
Dim x As Integer
NumRows = Range("A42", "A398").Rows.Count
Range("A42").Select
If ActiveSheet.Shapes("checkbox2").OLEFormat.Object.Value = 1 Then
For x = 42 To NumRows + 41 Step 1
If Worksheets("Base").Range("D" & x).Value = "x" Then
Worksheets("Base").Range(x & ":" & x).EntireRow.Hidden = False
Else
Worksheets("Base").Range(x & ":" & x).EntireRow.Hidden = True
End If
Next
Else
For x = 42 To NumRows + 41 Step 1
If Worksheets("Base").Range("C" & x).Value = "x" Then
Worksheets("Base").Range(x & ":" & x).EntireRow.Hidden = False
Else
Worksheets("Base").Range(x & ":" & x).EntireRow.Hidden = True
End If
Next
End If
MsgBox ("Done")
End Sub
You could use array formula and let Excel to return array with row-numbers where 'x' value occures. It will be quicker but you'll have to reorganise your code and create separate functions etc.
Here example where array formula finds rows whre in column 'D' the cell has value 'x'. Then string of this row numbers is created in form of "A1,A5,A10" ...means 'x' was found in rows 1,5,10. And finally Range(rowsJoind).EntireRow.Hidden is used for all the rows to be hidden/un-hidden in one step.
For rows with value different then 'x' you'll have to use formula like '=IF({0}<>""x"", ROW({0}), -1)'.
Sub test()
Dim inputRange As Range
Dim lastRow As Long
Dim myFormula As String
Dim rowsJoined As String, i As Long
Dim result As Variant
With Worksheets("Base")
lastRow = .Range("D" & .Rows.Count).End(xlUp).Row
Set inputRange = .Columns("D").Resize(lastRow)
Application.ReferenceStyle = xlR1C1
myFormula = "=IF({0}=""x"", ROW({0}), -1)"
myFormula = VBA.Strings.Replace(myFormula, "{0}", inputRange.Address(ReferenceStyle:=xlR1C1))
result = Application.Evaluate(myFormula)
result = Application.Transpose(result)
Application.ReferenceStyle = xlA1
For i = LBound(result) To UBound(result)
If (result(i) > -1) Then
rowsJoined = rowsJoined & "A" & result(i) & IIf(i < UBound(result), ",", "")
End If
Next i
.Range(rowsJoined).EntireRow.Hidden = False
End With
End Sub