I've looked through multiple questions/posts and can't find exactly what I'm looking for.
I have a worksheet that people enter sample names and DNA quant values. The worksheet calculates the volumes of reagents that need to be added to the reaction. The analyst indicates if the sample is destructive or was concentrated (microcon). All of this works fine.
I'm trying to add another macro that highlights a cell if another cell has specific text. The specific text is pulled by the VBA code. The analyst uses that info to enter a volume into a message box. I've tried a bunch of different ways and nothing is working. I think the best way is to have a conditional formatting rule, but I'm not sure how to do that in vba. I'm sure there's a better way to do this, but my vba is pretty basic.
Here is an example of the data. Right now I have a conditional formatting rule that highlights the ul DNA cell if the Destructive column is Y. But, what I would like to do is highlight all the ul of DNA cells that have the sample name "021021RWB_". The sample name would change depending on what the analyst fills out.
Worksheet example
This is what I have so far:
Sub DestructiveRBsTest()
Dim filename As String
Dim sheet As Worksheet
Dim row As Long
Dim column As Long
Dim sample As String
Dim tube As Long
Dim strMsg1 As String
Dim strMsg2 As String
Dim strTitle As String
For row = 8 To 25
tube = Cells(row, 1)
sample = Cells(row, 2)
Quant = Cells(row, 3)
Destructive = Cells(row, 8)
Microcon = Cells(row, 9)
SampleDilution = Cells(row, 5)
DNA = Cells(row, 6)
TE = Cells(row, 7)
If Quant = "RB" And Destructive = "Y" Then
SetID = Split(sample, " ")(0)
MsgBox "Destructive SetID is " & SetID
'Need something here that highlights the DNA cell for all sample cells that have the SetID
strMsg1 = "RB volume should match highest volume of undiluted destructive extract in extraction set."
strMsg2 = "How much volume of DNA should be added for " & sample & "?"
strTitle = "RB associated w/ Destructive Extract"
RBvolume = InputBox(strMsg1 & vbCrLf & vbCrLf & strMsg2, strTitle)
Cells(row, 6) = RBvolume
Cells(row, 7) = 15 - Cells(row, 6)
Else
Cells(row, 6) = "15"
Cells(row, 7) = "0"
End If
Next row
End Sub
Related
So my problem is that for previous users who are keeping track of inventory they have labeled items with a ID of example: ABC1234 - ABC1244 but the problem is that when we keep track of our items we need each and ever individual item to be properly accounted for as each item has a unique ID that we track.
So for the past half a year we have been slowly filling in everything and since there are tons of other information in the row that is repeated I was wondering if there was a way to write a VBA macro to expand and insert these rows of data.
So from this
ID
Description
ABC1234 - ABC1237
Screw type A
to this
ID
Description
ABC1234
Screw type A
ABC1235
Screw type A
ABC1236
Screw type A
ABC1237
Screw type A
I have tried using the record macro functions but its not dynamic which is not what I want as the Database can change over time with the influx of new items so I hope there is a way to dynamically complete this process. If anyone knows a solution please help have been banging my head against a wall for awhile now :'D
not sure if this is what you are looking for.
I am assuming your ABC is always the same, the only thing that is changing is the last 4 number.
Sub Formatting()
Dim xlwrks As Object
Dim xlrng As Object
Dim xlcell As Object
Dim lowerlimit As Integer, upperlimit As Integer
Set xlwrks = ThisWorkbook.Sheets("Sheet1")
Set xlrng = xlwrks.Range("A2", xlwrks.Range("A" & Rows.Count).End(xlUp).Address) 'from A2 to last cell in column A
For Each xlcell In xlrng 'iterate ech cell from xlrng
'e.g splitting this into array of string with the delimiter " - " by using split
'which will look something like "ABC1234", "ABC1237" for A2 and "ABC1238", "ABC1242" for A3
'next we only the last 4 number, by using right
lowerlimit = Right(Split(xlcell.Value2, " - ")(0), 4)
upperlimit = Right(Split(xlcell.Value2, " - ")(1), 4)
Do Until lowerlimit = upperlimit + 1
xlwrks.Range("D" & Rows.Count).End(xlUp).Offset(1, 0).Value2 = "ABC" & lowerlimit
xlwrks.Range("D" & Rows.Count).End(xlUp).Offset(0, 1).Value2 = xlcell.Offset(0, 1).Value2
lowerlimit = lowerlimit + 1
Loop
Next xlcell
End Sub
adding on to the requirement, as mentioned, need to monitor the trend. wrote something to check for the trend instead of manually eyeball the trend. Do note with this, the run time will be longer, because it will loop through each cell to look at the array, it will also loop through each array to look at each character. hope this help happy coding!~~
Dim xlwrks As Object
Dim xlrng As Object
Dim xlcell As Object
Dim lowerlimit As Long, upperlimit As Long
Dim charpos As Integer, characters As String, ID As String
Set xlwrks = ThisWorkbook.Sheets("Sheet1")
Set xlrng = xlwrks.Range("A2", xlwrks.Range("A" & Rows.Count).End(xlUp).Address) 'from A2 to last cell in column A
For Each xlcell In xlrng 'iterate ech cell from xlrng
'e.g splitting this into array of string with the delimiter " - " by using split
'which will look something like "ABC1234", "ABC1237" for A2 and "ABC1238", "ABC1242" for A3
'next we only the last 4 number, by using right
characters = Split(xlcell.Value2, " - ")(0)
For charpos = 1 To Len(characters)
If Not IsNumeric(Mid(characters, charpos, 1)) Then
ID = ID & Mid(characters, charpos, 1)
Else
Exit For
End If
Next charpos
For charpos = 1 To Len(characters)
If IsNumeric(Mid(characters, charpos, 1)) Then
lowerlimit = CStr(lowerlimit) & CStr(Mid(characters, charpos, 1))
End If
Next charpos
characters = Split(xlcell.Value2, " - ")(1)
For charpos = 1 To Len(characters)
If IsNumeric(Mid(characters, charpos, 1)) Then
upperlimit = CStr(upperlimit) & CStr(Mid(characters, charpos, 1))
End If
Next charpos
Do Until lowerlimit = upperlimit + 1
xlwrks.Range("D" & Rows.Count).End(xlUp).Offset(1, 0).Value2 = ID & lowerlimit
xlwrks.Range("D" & Rows.Count).End(xlUp).Offset(0, 1).Value2 = xlcell.Offset(0, 1).Value2
lowerlimit = lowerlimit + 1
Loop
lowerlimit = 0
upperlimit = 0
ID = ""
Next xlcell
Honestly, I would not do this with VBA inside the spreadsheet. I would write a separate piece of VB or VBScript that reads the existing spreadsheet and produces a new altered copy of it.
When it reads a line in the original spreadsheet with just "ABC1234", it just copies that line to the new spreadsheet. When it reads a line that contains "ABC1234 - ABC1237", it recognizes the pattern and figures out how many lines it needs to generate in the new spreadsheet. In this case, it will generate four lines: one line for ABC1234, one line for ABC1235, one line for ABC1236, and one line for ABC1237.
I think this approach will be easier to deal with than a VBA script inside the spreadsheet. You will run it once, check the new spreadsheet, then rename the old one for safe-keeping, and rename the new one to give it the original sheet's name.
So I have been stuck on this problem for a few days. I have looked at some others codes but I am still coming up short. I am not the best at VBA either.
I have a list of investors with their attached payments and dates. I am trying to run a command button that will go through each Account, find their related payments and dates, run the XIRR function and then place the XIRR value at the bottom to the right of each account. This is simple enough to do by hand but when you have a spreadsheet of 15000 cells+ it becomes tedious and I am trying to automate this process. It becomes difficult because each investor has different payment amounts so to find the correct location to place the XIRR value has also stumped me.
Here is an example of my spreadsheet
Dim i As Integer
Dim x As Double
Dim dateArray() As Date
Dim dateStrings() As String
Dim valArray() As Double
ReDim dateArray(Dates.Count)
ReDim valArray(Trans.Count)
ReDim dateStrings(Dates.Count)
'Sheets("InvestorList").PivotTables.GetPivotData("Account", "x") = i
'Sheets("AccountPayments").Find ("i")
End Sub
Public Function MyXIRR(Dates As Range, Trans As Range, Balance As Double)
For i = 1 To Dates.Count
dateArray(i - 1) = Dates.Item(i).Value
Next i
For i = 1 To Trans.Count
valArray(i - 1) = Trans.Item(i).Value
Next i
'Set the date on the "Balance" line to one day after the last transaction date
dateArray(Dates.Count) = DateAdd("d", 1, Dates.Item(Dates.Count))
valArray(Trans.Count) = -1 * Balance
For i = 0 To Dates.Count
dateStrings(i) = Format(dateArray(i), "mm/dd/yyyy")
Next i
MyXIRR = Application.WorksheetFunction.Xirr(valArray, dateStrings)
End Function
So I counseled with a college and he helped reduce my code to something much simpler and cleaner. I ran this code with data and it worked great. Some spot checking may be needed if an XIRR value doesn't appear right but this helps automate the process.
Private Sub CommandButton1_Click()
Dim myrow As Integer
Dim startrow As Integer
Dim valuerange As String
Dim daterange As String
Dim investor As String
myrow = 2
startrow = 2
investor = Cells(myrow, 1)
Do Until Cells(myrow, 1) = ""
If Cells(myrow + 1, 1) <> investor Then
'We are at the end of the list for the current investor.
daterange = "R" & startrow & "C2:R" & myrow & "C2"
valuerange = "R" & startrow & "C3:R" & myrow & "C3"
Cells(myrow, 4) = "=XIRR(" & valuerange & ", " & daterange & ")"
startrow = myrow + 1
investor = Cells(myrow + 1, 1)
End If
myrow = myrow + 1
Loop
End Sub
I would recommend trying the macro recorder to just record your steps... If you are unsure how to do so, here are the steps!
In Excel:
File
Options
Customize ribbon (left panel)
Choose commands from: (dropbox) select "Main Tabs"
Select developer
Click add>>
Click ok
Click developer tab now on top ribbon
Click record macro (top left corner)
Name macro, set shortcut and description if desired
Do what you want the macro to do.
When you completed it for one investor click stop recording
Click Macros in top left
Select the macro you just made and click edit
Should have a skeleton routine to work into your loop
I have a userform in which user can fill the data and data will insert in column C to Z. I need a code, either in worksheet or in userform to auto fill serial number starting with BA00860 which will fill in column A everytime data has enter.
I tried with the below Code under the Commandbutton_Click I was able to generate Serial numbers from BA00860 to BA00869, then after it is starting with BA01861 but not BA00870. Please correct my code as I required to be BA00860 … BA00870 … BA00880 and so on.
Me.txtId.Value = "BA" & Format(Application.Max(Sheets("Tasks").Range("A12:A65536")) + 1, "00860")
ActiveCell.Offset(0, 0).Value = Me.txtId.Value
ActiveCell.Offset(0, 0).NumberFormat = "00860"
Note that this .NumberFormat = "00860" is no valid number format.
You can do this easily with a formula. Assume your first serial number is written in A1 like …
Then you can just use the formula =LEFT(A1,2) & TEXT(RIGHT(A1,5)+1,"00000") in cell A2 and copy it down to get the following:
In VBA you could use something like
Dim LastSN As String
LastSN = Range("A1").Value 'eg BA00860
Dim NextSN As String
NextSN = Left$(LastSN, 2) & Format$(Right(LastSN, 5) + 1, "00000")
Full example according comments:
Sub Test()
Dim LastSN As String
LastSN = "BA00860"
Dim NextSN As String
NextSN = Left$(LastSN, 2) & Format$(Right(LastSN, 5) + 1, "00000")
MsgBox "LastSN was: " & LastSN & vbCrLf & "NextSN is: " & NextSN
End Sub
I've just created a brand new macro. Took function down below from internet (all credits goes to trumpexcel.com), code down below
Function CONCATENATEMULTIPLE(Ref As Range, Separator As String) As String
Dim Cell As Range
Dim Result As String
For Each Cell In Ref
Result = Result & Cell.Value & Separator
Next Cell
CONCATENATEMULTIPLE = Left(Result, Len(Result) - 1)
End Function
Then I proceed to extract data from various columns and into the one (my table is 20 rows x 10 columns)
Sub conact_data()
Dim i As Integer
For i = 2 To Cells(Rows.Count, "A").End(xlUp).Row
Cells(i, "M").Value = Cells(i, "A").Value & " " & _
Cells(i, "B").Value & " / " & Cells(i, "D").Value & "; "
Next i
End Sub
Thanks to that I've got combined data from column A, B and D, so its 20 rows. All I want to do now is to concatenate data from M2:M21 using CONCATENATEMULTIPLE function therefore I try various approach (I want this huge line in P2 cell) like :
Cells(2, 16).Value = CONCATENATEMULTIPLE (M2:M21, " ")
or
Range("P2") = "CONCATENATEMULTIPLE (M2:M21, " ")"
I don't really know how to apply that
Secondly, I'd like withdraw the Cells(i, "B").Value as percentage. Can I do that in one line like Cells(i, "B").NumberFormat="0.00%".Value (which is not working for me obviously) else I need to copy column B into another column with number format and then combine the new column, properly formatted instead of column B?
Thanks in advance
Percent format: Range("B" & i).NumberFormat = "0.00%"
CONCATENATEMULTIPLE
In VBA, CHR(32) = " "
In Excel, CHAR(32) = " "
With that being said...
'Value
Range("P2").Value = CONCATENATEMULTIPLE(Range("M2:M21"), CHR(32))
'Formula
Range("P2").Formula = "=CONCATENATEMULTIPLE(M2:M21, CHAR(32))"
You should really qualify all of your ranges with a worksheet
Say your workbook has 10 sheets. When you say Range("P2"), how do we (VBE) know what sheet you mean? Objects need to be properly qualified. Sometimes this is not a huge issue, but when you are working across multiple sheets, not qualifying ranges can lead to some unexpected results.
You can qualify with a worksheet a few ways.
Directly: ThisWorkbook.Sheets("Sheet1").Range("P2").Copy
Or use a variable like so
Dim ws as Worksheet: Set ws = ThisWorkbook.Sheets("Sheet1")
ws.Range("P2").Copy
Now there is no room for ambiguity (potential errors) as to the exact location of Range("P2")
First of all, remove your ConcatenateMultiple() code, and instead use Excel worksheet function CONCAT(), which takes a range and a delimiter as parameters.
Here is how you can handle the percentage issue and supply a default for non-numeric items. I've also cleaned up the way you reference your data range.
Sub concat_data()
Dim rngRow As Range, vResult As Variant
Const DEFAULT = 0 'Can also be set to a text value, eg. "Missing"
For Each rngRow In [A2].CurrentRegion.Rows
If IsNumeric(rngRow.Cells(, 4)) Then vResult = rngRow.Cells(, 4) * 100 & "%" Else vResult = DEFAULT
Range("M" & rngRow.Row) = rngRow.Cells(, 1) & rngRow.Cells(, 2) & "/" & vResult & ";"
Next
[M2].End(xlDown).Offset(1).Formula = "=CONCAT(M2:M" & [M2].End(xlDown).Row & ",TRUE,"" "")"
End Sub
I'm not a fan of hard-coding range references, like the [A2] or Range("M"), but will leave that for another time.
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