HI I am trying to search for a sub string within a string and if the sub string is found then I want to paste the output to my spreadsheet. I am using th InStr function with a conditional statement <> , so that if mt InStr function value is not equal to 0 I know I have a match. I do not get any errors when I run the code but it does not display the result on the sheet. SOS!! :)
Sub unicornhorn()
'Generates user friendly graphs from raw unicorn input data
Dim columns As Integer
Dim rows As Integer
Dim Outputs(50) As String
Dim LastRow As Integer
Dim StrG As Integer
Dim xaxis As Range
Dim yaxis As Range
Dim nLeft As Double: nLeft = 20
Dim nTop As Double: nTop = 20
Dim start As Double: start = start + 2
Dim finish As Double: finish = finish + 2
Dim Curves(14) As String
Curves(0) = "260nm"
Curves(1) = "280nm"
Curves(2) = "214nm"
Curves(3) = "Cond"
Curves(4) = "Cond%"
Curves(5) = "Conc"
Curves(6) = "pH"
Curves(7) = "Pressure"
Curves(8) = "Flow"
Curves(9) = "Temp"
Curves(10) = "Fractions"
Curves(11) = "inject"
Curves(12) = "logbook"
Curves(13) = "P960_Press"
Curves(14) = "P960_Flow"
Dim D As Worksheet
Set D = Worksheets("DATA")
Dim C As Worksheet
Set C = Worksheets("sheet1")
'defines data range
columns = shCurves.Cells(1, shCurves.columns.Count).End(xlToLeft).Column
'XXreturn check to sheet
ShData.Cells(5, 5).Value = columns
rows = shCurves.Cells(shCurves.rows.Count, 1).End(xlUp).Row
'XXreturn check to sheet
ShData.Cells(5, 6).Value = rows
For Z = 0 To columns
'loops through array for different curves
Outputs(Z) = shCurves.Cells(2, Z * 2 + 1).Value
'XXreturn check to sheet
ShData.Cells(5 + Z, 7).Value = Outputs(Z)
'Finds last row in column for current curve
LastRow = Cells(D.rows.Count, Z * 2 + 1).End(xlUp).Row
For k = 0 To 14
'finds curve identifyer within string
StrG = InStr("Outputs(Z)", "Curves(k)")
If StrG <> 0 Then
ShData.Cells(25 + k, 5).Value = Curves(k)
Exit For
End If
Next k
Next Z
End Sub
Why do you have double quotes around your arrays?
StrG = InStr("Outputs(Z)", "Curves(k)")
You're using the string literals, not the variables. Remove the double quotes:
StrG = InStr(Outputs(Z), Curves(k))
Related
Trying to only round the numbers in column 4 but this macro code isn't working properly. Maybe there is another way to word it.
It is using a selection for the range but I think there has to be another way of putting this.
Thank you.
Sub RoundNumbersInColumn()
Dim rowMax As Long
Dim rowStart As Long
Dim colNo As Long
Dim aCell As Cell
Dim aTable As Table
Dim tabPos As Single
Dim k As Long
Dim aValue As Single
Dim formatStr As String
Dim s As String
' set format to number of decimal places to round to
formatStr = "#0.0000"
Set aTable = Selection.Tables(1)
rowMax = aTable.Rows.Count
Set aCell = Selection.Cells(1)
rowStart = aCell.RowIndex
colNo = aCell.ColumnIndex
tabPos = -1
If aCell.Range.ParagraphFormat.TabStops.Count > 0 Then
If aCell.Range.ParagraphFormat.TabStops.Item(1).Alignment = wdAlignTabDecimal Then _
tabPos = aCell.Range.ParagraphFormat.TabStops.Item(1).Position
End If
For k = rowStart To rowMax
Set aCell = aTable.Cell(Row:=k, Column:=4)
s = aCell.Range.Text
s = Left(s, Len(s) - 1)
If IsNumeric(s) Then
aValue = Val(s)
With aCell.Range.ParagraphFormat.TabStops
.ClearAll
.Add Position:=tabPos, Alignment:=wdAlignParagraphCenter
End With
aCell.Range.Text = Format(Str(aValue), formatStr)
End If
Next k
End Sub
Remove the underline after Then in line 26. Then add an End If to close the first If statement. Like so:
If aCell.Range.ParagraphFormat.TabStops.Count > 0 Then
If aCell.Range.ParagraphFormat.TabStops.item(1).Alignment = wdAlignTabDecimal Then
tabPos = aCell.Range.ParagraphFormat.TabStops.item(1).Position
End If
End If
I am working with a schedule, that I have imported and formatted into my workbook.
I am wanting this to populate Phase in the upper listbox and then when a phase is selected the sub-task associated with those phases are displayed in the bottom listbox.
I want to use an array but I seem to be having problems when the columns are not next to each other or there are "gaps" with the blank cells.
My first attempt using assigning the Array to the currentregion worked but brought all columns and fields in. Listbox1 should contain (ID, PHASE NAME, DURATION, START DATE, FINISH DATE) List box 2 should when a Phase is selected contain the subtasks if any from the column to the right, listed before the next next Phase name. (ID, SUB-TASK NAME, DURATION, START DATE, FINISH DATE)
(See picture)
I have code but its more me trouble-shooting than an actual semi working script.
Dim shT As Worksheet
Dim schnumrng1 As Range
Dim schnumrng2 As Range
Dim schnumrng3 As Range
Dim schnumrng4 As Range
Dim schnumrng5 As Range
Dim schpersonrng As Range
Dim schphaserng As Range
Dim schlistrng As Range
Dim maxschnum
Dim schstatus
Dim schperson
Dim schlistnum
Dim Ar() As String
Dim i As Long
Dim j As Long
Dim rng As Range
Dim cl As Range
Dim lc
'allowevents = True
''Set Screen parameters
'Application.ScreenUpdating = False
'Application.EnableEvents = False
'
Worksheets("Schedule").Visible = True
ThisWorkbook.Worksheets("Schedule").Activate
'
Set shT = Worksheets("Schedule")
maxschnum = shT.Cells(shT.Rows.Count, "A").End(xlUp).Row
Set schnumrng = Range("B5", "B" & maxschnum)
'Set Ranges for the list box
Set schnumrng1 = Range("A5", "A" & maxschnum)
Set schnumrng2 = Range("B5", "B" & maxschnum)
Set schnumrng3 = Range("D5", "D" & maxschnum)
Set schnumrng4 = Range("E5", "E" & maxschnum)
Set schnumrng5 = Range("F5", "F" & maxschnum)
'This is static and not moving to the next line in my for statement / switched to named ranges and errors
Set rng = schnumrng1, schnumrng2, schnumrng3, schnumrng4, schnumrng5
'Set rng = Range("A5,B5,D5,E5,F5")
i = 1
j = 1
For Each lc In schnumrng
If lc <> vbNullString Then
For Each cl In rng
ReDim Preserve Ar(1, 1 To i)
Ar(j, i) = cl.Value
i = i + 1
Next cl
Else
End If
j = j + 1
Next lc
With ScheduleForm.SchMainTasklt
.ColumnCount = i - 1
.ColumnWidths = "50;150;50;50;50"
.List = Ar
End With
My problem then is two fold, trying to use the dynamic ranges or another tool Index? collection? to populate the 1st list box. 2. How to deal with blanks and noncontiguous columns when data is not separated for organization purposes.
I don't know if I figured out your intentions well.
First, only the data in column b, not empty cells, is extracted from listbox1.
Second, when listbox1 is selected, data related to listbox2 is collected through the selected listbox value.
Module Code
Place this code in the module. This is because global variables must be used.
Public vDB As Variant
Public Dic As Object 'Dictionary
Sub test()
Dim shT As Worksheet
Dim maxschnum As Long
Dim Ar() As String
Dim i As Long
Dim j As Long
Dim vC() As Variant
Dim cnt As Integer, n As Integer
Dim c As Integer
Dim s As String, s2 As String
Worksheets("Schedule").Visible = True
ThisWorkbook.Worksheets("Schedule").Activate
'
Set Dic = CreateObject("Scripting.Dictionary") 'New Scripting.Dictionary
Set shT = Worksheets("Schedule")
maxschnum = shT.Cells(shT.Rows.Count, "A").End(xlUp).Row
With shT
vDB = .Range("a5", .Range("f" & maxschnum))
End With
'vC is data colum A,B,D,E,F
vC = Array(1, 2, 4, 5, 6)
s2 = vDB(2, 2)
For i = 2 To UBound(vDB, 1)
s = vDB(i, 2) 'column B
If s = "" Then
n = n + 1
Else
If Dic.Exists(s) Then
Else
If i > 2 Then
Dic(s2) = Dic(s2) & "," & n
End If
Dic.Add s, i
s2 = s
cnt = cnt + 1
ReDim Preserve Ar(1 To 5, 1 To cnt)
For c = 0 To UBound(vC)
Ar(c + 1, cnt) = vDB(i, vC(c))
Next c
End If
n = 0
End If
Next i
Dic(s2) = Dic(s2) & "," & n
' Records information about the data in a dictionary.
' Dic is "phase neme" is Key, Item is "2,4"
' example for KICkOFF
' dic key is "KICKOFF", Item is "5,4"
' 5 is KICOFF's row number in array vDB
' 4 is the number of blank cells related to kickoff.
With ScheduleForm.SchMainTasklt
.ColumnCount = 5
.ColumnWidths = "50;150;50;60;60"
.BoundColumn = 2
'.List = Ar
.Column = Ar 'In the state that the array has been converted to row column, you can use listbox.column.
End With
End Sub
Form Code
Private Sub UserForm_Initialize()
Call test
End Sub
Private Sub SchMainTasklt_Click()
Dim s As String, sItem As String
Dim arr As Variant, vC As Variant
Dim vR() As Variant
Dim st As Long, ed As Long
Dim iLast As Long, iFirst As Long
Dim i As Long, n As Integer
Dim j As Integer
vC = Array(1, 3, 4, 5, 6) 'data colums A,C,D,E,F
s = SchMainTasklt.Value
'MsgBox s
sItem = Dic(s)
arr = Split(sItem, ",")
st = Val(arr(0))
ed = Val(arr(1))
iFirst = st + 1
iLast = st + ed
If ed = 0 Then
MsgBox "no data!!"
Exit Sub
End If
For i = iFirst To iLast
n = n + 1
ReDim Preserve vR(1 To 5, 1 To n)
For j = 0 To UBound(vC)
vR(j + 1, n) = vDB(i, vC(j))
Next j
Next i
With ListBox2
.ColumnCount = 5
.ColumnWidths = "50;150;50;60;60"
.BoundColumn = 2
.Column = vR
End With
End Sub
Result Image
When you click the "KICKOFF" , Show kickoff related data in listbox2.
I am trying to count the number of occurrence for this phrase "SMM:" in each row in column AJ starting from row 2 and then assign the assign the value for each row to column BL starting from row 2.
Sub calculateamlp()
Dim charactercount As Integer
Dim rangeAG As Range
Dim cellCheck As Range
Dim f As Integer
f = 2
Worksheets("pptsr").Activate
Set rangeAG2 = Range("BL2", Range("BL2").End(xlDown))
Set rangeAG = Range("Aj2", Range("Aj2").End(xlDown))
For Each cellCheck In rangeAG
charactercount = Len(cellCheck) - Len(WorksheetFunction.Substitute(cellCheck, ":", ""))
Worksheets("pptsr").Range("BL2" & f).Value = charactercount
f = f + 1
Next cellCheck
End Sub
This function get the count by counting the number of elements in Splitting the String using the with the Substring.
Function getStrOccurenceCount(Text As String, SubString As String)
getStrOccurenceCount = UBound(Split(Text, SubString))
End Function
You could modify your code like this
Worksheets("pptsr").Range("BL2" & f).Value = getStrOccurenceCount(cellCheck.Text, "SMM:")
Here is how you could use the getStrOccurenceCount with arrays to improve your efficiency.
Sub calculateamlp2()
Const SUBSTRING As String = "SMM:"
Dim rangeAG As Range
Dim data As Variant
Dim x As Long
Set rangeAG = Range("AJ2", Range("AJ2").End(xlDown))
data = rangeAG.Value
For x = 1 To UBound(data)
data(x, 1) = getStrOccurenceCount(CStr(data(x, 1)), SUBSTRING)
Next
rangeAG.EntireRow.Columns("BL").Value = data
End Sub
Demo: Sample data 999,999 rows, execution time 0.9375 Seconds:
For exact match you should use "vbBinaryCompare". If you want to match "smm:" with "SMM:" then you should use "vbTextCompare". Try this:
Sub calculateamlp()
Dim count As Long, i As Long, j As Long, rw As Long
Dim ws As Worksheet
Set ws = Worksheets("pptsr")
With ws
rw = .Range("AJ" & .Rows.count).End(xlUp).Row
For i = 2 To rw
For j = 1 To Len(.Cells(i, "AJ"))
If InStr(j, .Cells(i, "AJ"), "SMM:", vbTextCompare) Then
count = count + 1
j = InStr(j, .Cells(i, "AJ"), "SMM:", vbTextCompare)
End If
Next j
.Cells(i, "BL") = count
count = 0
Next
End With
End Sub
I need help with excel vba programing, I need to group values in a For loop and print grouped list to other sheet, here is my code
Dim grafikas As Worksheet
Dim akcijos As Worksheet
Dim x As Integer
Dim prekeskodas As Long
Dim lastrow As Integer
Dim laikas As Date
Dim ats As String
Set grafikas = Sheets("GRAFIKAS")
Set akcijos = Sheets("AKCIJOS")
lastrow = akcijos.Cells(Rows.Count, 1).End(xlUp).Row
paskeil = grafikas.Cells(Rows.Count, 1).End(xlUp).Row
prekeskodas = grafikas.Range("B48").Value
laikas = grafikas.Range("F1").Value
laikas2 = grafikas.Range("CK1").Value
For x = 2 To lastrow
If akcijos.Cells(x, 4) = prekeskodas And akcijos.Cells(x, 8) >= laikas Then
ats = akcijos.Cells(x, 3)
Sheets("grafikas").Range("C7") = ats
Debug.Print akcijos.Cells(x, 3)
End If
Next x
Problem:
I have a code that does everything it should, only it does not 'finish' its work. Whenever I run this code, it seems that the last 2 rows are not included.
Code:
Sub List()
Dim sStDev As Worksheet: Set sStDev = Sheets("StDev")
Dim sResult As Worksheet: Set sResult = Sheets("Large")
Dim sQuart As Worksheet: Set sQuart = Sheets("Quintile")
Dim sReturn As Worksheet: Set sReturn = Sheets("Return")
Dim j As Long
Const colDate As Long = 1
Const rowStDevFirst As Long = 2
Const rowResultFirst As Long = 2
Dim LastRow As Long
LastRow = sReturn.Cells(Rows.Count, "A").End(xlUp).Row
Dim rowResult As Long: rowResult = rowResultFirst
j = 2
Dim i As Long: For i = rowStDevFirst To LastRow
Dim colResult As Long: colResult = 1
sResult.Cells(rowResult, colResult).Value = sStDev.Cells(i, colDate).Value
colResult = colResult + 1
For j = 1 To 792
If sStDev.Cells(i, j).Value >= sQuart.Range("F2").Offset(i, 0) And sStDev.Cells(i, j).Value <= sQuart.Range("G2").Offset(i, 0) Then
sResult.Cells(rowResult, colResult).Value = sReturn.Cells(i, j).Value
colResult = colResult + 1
End If
Next j
rowResult = rowResult + 1
Next i
MsgBox "Listed"
End Sub
How can I make this code include my last two rows as well?
Thank you in advance!
File: File
As I see you try to fill out the Large sheet with these values from Return sheet for which the corresponding value in StDev is between F and G values in Quintile for each row.
It's Ok, but you shouldn't offset the values in Quintile by i as even for the second row you get the Quintile!F4 and G4 instead of F2 and G2.
So to fix it you should change sQuart.Range("F2").Offset(i, 0) to sQuart.Range("F2").Offset(i-2, 0)
and the same for column G: Offset(i, 0) should be Offset(i-2, 0)