My Excel raw data looks something like this:
;123456p,Roses and butterflies;;124456h,Violets are blue;
;123456d,Hello world;
Expected output:
Roses and butterflies
Violets are blue
Hello world
Trying to split the text sentences out only, for rows with multiple sentences I would need them in
separate rows, is this at all possible? Below is what I tried.
Private Sub CommandButton1_click()
Dim splitstring As String
Dim myarray() As String
splitstring = Worksheets("raw").Cells(1, 1).Value
myarray = Split(splitstring, ";")
For i = 0 To URound(myarray)
Next
End Sub
Sub raw()
End Sub
With Regular Expressions, you can populate Column B with the desired results ae below
Option Explicit
Private Sub CommandButton1_click()
Dim wSh As Worksheet
Dim rngStr As String, rngStrArr() As String, i As Long
Set wSh = Worksheets("raw")
Dim regEx As Object, mc As Object
Set regEx = CreateObject("vbscript.regexp")
regEx.Global = True
regEx.IgnoreCase = True
rngStr = Join(Application.Transpose(Application.Index(( _
wSh.Range("A1:A" & wSh.Cells(wSh.Rows.Count, 1).End(xlUp).Row)), 0, 1)))
regEx.Pattern = ",([^;]+);"
Set mc = regEx.Execute(rngStr)
rngStr = ""
For i = 0 To mc.Count - 1
rngStr = rngStr & mc(i)
Next i
rngStr = Replace(rngStr, ",", "")
rngStrArr = Split(rngStr, ";")
wSh.Range("B1").Resize(UBound(rngStrArr), 1).Value = Application.Transpose(rngStrArr)
End Sub
Try this:
Private sub SplitString()
Dim splitstring As String
Dim myarray() As String
splitstring = Cells(1, 1).Value
myarray = Split(splitstring, ",")
For i = 1 To UBound(myarray)
MsgBox (myarray(i))
Next
End Sub
Related
I am trying to Vlookup a cell to return a match in a contact list.
When it finds that match it should send an email to the person associated with that location.
Sub vLookupAnotherWorksheet()
Dim myLookupValue As String
Dim myFirstColumn As Long
Dim myLastColumn As Long
Dim myColumnIndex As Long
Dim myFirstRow As Long
Dim myLastRow As Long
Dim myVLookupResult As Long
Dim myTableArray As Range
myLookupValue = "H3:H13"
myFirstColumn = 1
myLastColumn = 8
myColumnIndex = 8
myFirstRow = 3
myLastRow = 13
With Worksheets("EVC_Contact_List")
Set myTableArray = .Range(.Cells(myFirstRow, myFirstColumn), .Cells(myLastRow, myLastColumn))
End With
On Error Resume Next
myVLookupResult = WorksheetFunction.VLookup(myLookupValue, myTableArray, myColumnIndex, False)
If IsError(myVLookupResult) = False Then
Call Send_Email(myvalue)
End If
End Sub
Sub Send_Email(myvalue As Variant)
Dim Email_Subject As String, Email_Send_From As String, Email_Body As String, i As Integer
Dim Mail_Object As Object, nameList As String, namelist2 As String, o As Variant
Email_Send_From = ""
If Sheets("EVC_Contact_List").Cells(2, 4).Value <> "" Then
nameList = Join(Application.WorksheetFunction.Transpose(Sheets("EVC_Contact_List").Range("D2:D29")))
namelist2 = Join(Application.WorksheetFunction.Transpose(Sheets("EVC_Contact_List").Range("F2:F29")))
End If
Set Mail_Object = CreateObject("Outlook.Application")
With Mail_Object.CreateItem(o)
.Subject = "Unit(s) Excceding Days as Loaner"
.To = nameList
.Cc = namelist2
.display
End With
Application.DisplayAlerts = False
End Sub
If location XXXX is found on the contact list and Johnsmith#gmail.com is associated with that location it should send an email only to John Smith.
My code is sending an email to everyone on the contact list.
You have this:
nameList = Join(Application.WorksheetFunction.Transpose(Sheets("EVC_Contact_List").Range("D2:D29")))
Should that not be the Vlookup function?
I want to sum the same range of values (say B3:B292) in 120 worksheets such that: ΣB3, ΣB4, ΣB5 ...... ΣB292.
I am not getting an error for the below VBA code, but it's also not returning any values.
Sub FAggreg1PNFAWO()
Dim Aggreg1PNFAWO As Workbook
Dim WS_Count As Integer
Dim filePath As String
Dim i As Integer
Dim TotalNp As Variant
filePath = "Directory"
Set Aggreg1PNFAWO = Workbooks.Open(filePath, ReadOnly:=True)
WS_Count = Aggreg1PNFAWO.Worksheets.Count
For i = 1 To WS_Count
'Sheets(i).range("B3:B292") <> "" And
If IsNumeric(Sheets(i).range("B3:B292")) Then
TotalNp = TotalNp + Sheets(i).range("B3:B292")
End If
Next
ActiveWorkbook.Close
ThisWorkbook.Activate
ActiveSheet.range("T4:T293").Value = TotalNp
End Sub
In that case try this:
Sub FAggreg1PNFAWO()
Dim Aggreg1PNFAWO As Workbook, myWB As Workbook
Dim WS_Count As Integer, i As Integer
Dim filePath As String
Dim TotalNp As Variant
Set myWB = ActiveWorkbook
filePath = "Directory"
Set Aggreg1PNFAWO = Workbooks.Open(filePath, ReadOnly:=True)
WS_Count = Aggreg1PNFAWO.Worksheets.Count
For X = 3 To 292
For i = 1 To WS_Count
If IsNumeric(Sheets(i).Range("B" & X)) Then
TotalNp = TotalNp + Sheets(i).Range("B" & X).Value
End If
Next
myWB.Activate
myWB.ActiveSheet.Range("T" & i + 1).Value = TotalNp
TotalNp = 0
Aggreg1PNFAWO.Activate
Next X
End Sub
Here you can use SUM function to do this. In the below answer am assuming B293 cell as empty and using it for summation. If you have some data in that cell then pick some other empty cell then try this.
Sub Sum()
Dim Project1P As Workbook
Dim WS_Count As Integer
Dim i As Integer
Dim V As Variant
Set Project1P = Workbooks.Open("C:\Users\Nandan\Desktop\SO\SO1.xlsx")
WS_Count = Project1P.Worksheets.Count
sumrange (WS_Count)
End Sub
Function sumrange(TotalSheets As Integer)
Dim reserves As Variant
For i = 1 To TotalSheets
Sheets(i).range("B" & 293).Formula = "=SUM(B3:B292)"
Next
For i = 1 To TotalSheets
reserves = reserves + Sheets(i).range("B" & 293)
Next
For i = 1 To TotalSheets
Sheets(i).range("B" & 293).Clear
Next
MsgBox "Total of all sheets :" & reserves
End Function
I would like to filter pivot table using inputbox. I need to make visible ony the user entered values and other values must be invisible. The pivot field "Number" is in Row Labels. I used loop in the code. so user the can enter multiple values. I used the code below but the problem is it is not working and showing Error "Subscript out of range". Help me
Sub FilterRP()
Dim ws As Worksheet
Dim str1 As Variant
Dim arr1() As String
Dim i As Long
Set ws = Sheets("Main")
i = 1
Do
str1 = Application.InputBox("Select one Number")
ReDim Preserve arr1(i)
arr1(i) = str1
i = i + 1
Loop While (str1 <> vbNullString) And (str1 <> False)
ws.PivotTables("MainTable").PivotFields("Number").ClearAllFilters
ws.PivotTables("MainTable").PivotFields("Number").PivotItems(arr1(i)).Visible = True
End Sub
You could try doing something like this. It takes an input from your InputBox separated by commas. Then loops through each item in the Pivot Field 'Number' setting the visibility if the value exists in the array. If the array IsEmpty (i.e. the input box was vbNullString) then it resets the Pivot Field and returns all items.
Sub FilterRP()
Dim ws As Worksheet
Dim str1 As Variant
Dim arr1() As String
Dim pi As PivotItem
Set ws = Sheets("Main")
str1 = InputBox("Please enter the numbers you want to filter by" & vbNewLine & "Seperated by a comma (,)")
' Remove spaces if any
str1 = Trim(Replace(str1, " ", vbNullString))
arr1 = Split(str1, ",")
With ws.PivotTables("MainTable").PivotFields("Number")
For Each pi In .PivotItems
If Not str1 = vbNullString Then
pi.Visible = IIf(IsInArray(pi.Name, arr1), True, False)
Else
pi.Visible = True
End If
Next pi
End With
End Sub
Public Function IsInArray(stringToBeFound As String, arr As Variant) As Boolean
Dim i
For i = LBound(arr) To UBound(arr)
If arr(i) = stringToBeFound Then
IsInArray = True
Exit Function
End If
Next i
IsInArray = False
End Function
Try the code below, explanations inside the code's comments:
Option Explicit
Sub FilterRP()
Dim ws As Worksheet
Dim str1 As Variant
Dim arr1() As String
Dim i As Long
Dim PvtItm As PivotItem
Set ws = Sheets("Main")
i = 0
Do
str1 = Application.InputBox("Select one Number")
ReDim Preserve arr1(i)
arr1(i) = str1
i = i + 1
Loop While (str1 <> vbNullString) And (str1 <> False)
With ws.PivotTables("MainTable").PivotFields("Number")
.ClearAllFilters ' reset previous filters
' loop through Pivot Items collection
For Each PvtItm In .PivotItems
If Not IsError(Application.Match(PvtItm.Name, arr1, 0)) Then ' check if current Pivot-Items's name equals to one of the selected values in Input-Box
PvtItm.Visible = True
Else
PvtItm.Visible = False
End If
Next PvtItm
End With
End Sub
seems that I am a bit rusty when it comes to vba programming. I have created a licence type (class/object) and wishing to add that to a collection type. I am trying to iterate over the collection but keep getting object required error 424. Code snippet below for advise. thanks in advance
Private Sub btnGenerate_Click()
Dim lic As licence
For Each lic In licenceCollection
Debug.Print lic.getClause
Next lic
End Sub
error produced on for each lic in licenceCollection
Private Sub cboHeading_Change()
Dim heading As String
Dim str As String
'Dim lic As Licence
Dim rngValue As Range
Dim ws As Worksheet
Dim last_row As Long
Dim arr()
Dim i As Long
'Dim lic As licence
heading = cboHeading.Value
Set licenceCollection = New collection
Select Case heading
Case "Future Sampling"
'str = "lorem ipsum"
'Utility.createCheckBoxes (str)
'grab data from Future Sampling ws
Set ws = Worksheets("Future_Sampling")
ws.Activate
last_row = Range("A2").End(xlDown).Row
Debug.Print last_row
ReDim arr(last_row - 2)
'add array to object type
For i = 0 To last_row - 2
arr(i) = Range("A" & i + 2)
'Debug.Print arr(i)
Next
Set licence = New licence
licence.setClause = arr
'Debug.Print lic.getDescription
'add licence to collection for later retrieval
licenceCollection.Add (arr)
Case Else
Debug.Print ("no heading")
End Select
'Set lic = Nothing
End Sub
Private Sub UserForm_Initialize()
Dim rngValue As Range
Dim ws As Worksheet
Set ws = Worksheets("Headings")
For Each rngValue In ws.Range("A2:A10")
Me.cboHeading.AddItem rngValue.Value
Next rngValue
'licenceForm.cboHeading.SetFocus
'create vertical scrollbar
With Me.resultFrame
.ScrollBars = fmScrollBarsVertical
End With
End Sub
Thanks guys, that fixed my issue.
Private Sub btnGenerate_Click()
Dim i As Long
Dim lic As licence
Dim temp As Variant
For Each lic In licenceCollection
temp = lic.getClause
Next lic
For i = LBound(temp) To UBound(temp) Step 1
Debug.Print temp(i)
Next
End Sub
Private Sub cboHeading_Change()
Dim heading As String
Dim str As String
'Dim lic As Licence
Dim rngValue As Range
Dim ws As Worksheet
Dim last_row As Long
Dim arr()
Dim i As Long
Dim lic As licence
heading = cboHeading.Value
Set licenceCollection = New collection
Select Case heading
Case "Future Sampling"
'str = "lorem ipsum "
'Utility.createCheckBoxes (str)
'grab data from Future Sampling ws
Set ws = Worksheets("Future_Sampling")
ws.Activate
last_row = Range("A2").End(xlDown).Row
Debug.Print last_row
ReDim arr(last_row - 2)
'add array to object type
For i = 0 To last_row - 2
arr(i) = Range("A" & i + 2)
'Debug.Print arr(i)
Next
Set lic = New licence
lic.setClause = arr
'Debug.Print lic.getDescription
'add licence to collection for later retrieval
licenceCollection.Add lic
Case Else
Debug.Print ("no heading")
End Select
'Set lic = Nothing
End Sub
I've got the code below which is extracting a string from brackets and it's ok, but now I've found out that sometimes in my string there can be more brackets with texts behind and I need to extract them too. For instance, a list or table.
e.g
hsus(irt)bla dsd (got)(rifk)
I need then: irt, got, rifk to list, how to do it?
Public Function extract_value(str As String) As String
dim str as string
dim openPos as integer
dim closePos as integer
dim midBit as string
str = "sometinhf(HELLO)sds"
openPos = instr (str, "(")
closePos = instr (str, ")")
midBit = mid (str, openPos+1, closePos - openPos - 1)
End Function
Sub Main()
Dim s$
s = "hsus(irt)bla dsd (got)(rifk)"
Debug.Print extract_value(s)
End Sub
Public Function extract_value$(s$)
Dim returnS$
Dim v
v = Split(s, Chr(40))
For Each Item In v
If InStr(Item, Chr(41)) Then
returnS = returnS & Chr(32) & Split(Item, ")")(0)
End If
Next
extract_value = Trim$(returnS)
End Function
You can use a Regexp to extract the matching strings directly
Sub Main()
Dim strTest as string
strTest = "hsus(irt)bla dsd (got)(rifk)"
MsgBox GrabIt(strTest)
End Sub
Function GrabIt(strIn As String) As String
Dim objRegex As Object
Dim objRegMC As Object
Dim objRegM As Object
Set objRegex = CreateObject("vbscript.regexp")
With objRegex
.Pattern = "\((.*?)\)"
.Global = True
If .test(strIn) Then
Set objRegMC = .Execute(strIn)
For Each objRegM In objRegMC
GrabIt = GrabIt & Chr(32) & objRegM.submatches(0)
Next
End If
End With
End Function