Error when splitting a string into an array - arrays

Basically, I can't trim it unless it's in a message box.. it's hard to explain.
Here's 2 Images:
1. http://gyazo.com/83b0a996e607f7013d998f6f800650f1
2. http://gyazo.com/e1fe9d8adb4a522479f6621d29e90e9d
Dim value As String = ary(0).Trim()
'Dim value1 As String = ary(1).Trim()
Dim R As String
Dim G As String
Dim B As String
Dim outline As String
Dim outlineColor As String
R = Chr(34) & "MouseColorR" & Chr(34)
G = Chr(34) & "MouseColorG" & Chr(34)
B = Chr(34) & "MouseColorB" & Chr(34)
outline = Chr(34) & "ThickMouseEdges" & Chr(34)
outlineColor = Chr(34) & "ThickMouseEdgesPackedColor" & Chr(34)
'based on the value after the equals sign, do something
If value = R Then
MsgBox(ary(1).Trim(Chr(44)))
ElseIf value = G Then
MsgBox("finally")
ElseIf value = B Then
MsgBox("finally")
ElseIf value = outline Then
MsgBox("finally")
this works^^^^
this doesnt:
Dim value As String = ary(0).Trim()
this is the error---> Dim value1 As String = ary(1).Trim()
Dim R As String
Dim G As String
Dim B As String
Dim outline As String
Dim outlineColor As String
R = Chr(34) & "MouseColorR" & Chr(34)
G = Chr(34) & "MouseColorG" & Chr(34)
B = Chr(34) & "MouseColorB" & Chr(34)
outline = Chr(34) & "ThickMouseEdges" & Chr(34)
outlineColor = Chr(34) & "ThickMouseEdgesPackedColor" & Chr(34)
'based on the value after the equals sign, do something
If value = R Then
MsgBox(ary(1).Trim(Chr(44)))
ElseIf value = G Then
MsgBox("finally")
ElseIf value = B Then
MsgBox("finally")
ElseIf value = outline Then
MsgBox("finally")
ElseIf value = outlineColor Then
MsgBox("finally")
and the error is :An unhandled exception of type 'System.IndexOutOfRangeException' occurred in Terraria Smart Cursor.exe
Additional information: Index was outside the bounds of the array.
Whole Code:
Public Class Form1
Private Sub NsCheckBox1_CheckedChanged(sender As Object) Handles NsCheckBox1.CheckedChanged
NsGroupBox2.Enabled = NsCheckBox1.Checked
End Sub
Private Sub NsTrackBar1_Scroll(sender As Object) Handles NsTrackBar1.Scroll
NsLabel4.Value1 = NsTrackBar1.Value
End Sub
Private Sub NsTrackBar2_Scroll(sender As Object) Handles NsTrackBar2.Scroll
NsLabel5.Value1 = NsTrackBar2.Value
End Sub
Private Sub NsTrackBar3_Scroll(sender As Object) Handles NsTrackBar3.Scroll
NsLabel6.Value1 = NsTrackBar3.Value
End Sub
Private Sub NsTrackBar6_Scroll(sender As Object) Handles NsTrackBar6.Scroll
NsLabel9.Value1 = NsTrackBar6.Value
End Sub
Private Sub NsTrackBar5_Scroll(sender As Object) Handles NsTrackBar5.Scroll
NsLabel8.Value1 = NsTrackBar5.Value
End Sub
Private Sub NsTrackBar4_Scroll(sender As Object) Handles NsTrackBar4.Scroll
NsLabel7.Value1 = NsTrackBar4.Value
End Sub
Private Sub NsButton1_Click_1(sender As Object, e As EventArgs) Handles NsButton1.Click
If ColorDialog1.ShowDialog() = Windows.Forms.DialogResult.OK Then
NsLabel4.Value1 = ColorDialog1.Color.R
NsLabel5.Value1 = ColorDialog1.Color.G
NsLabel6.Value1 = ColorDialog1.Color.B
NsTrackBar1.Value = NsLabel4.Value1
NsTrackBar2.Value = NsLabel5.Value1
NsTrackBar3.Value = NsLabel6.Value1
End If
End Sub
Private Sub NsButton2_Click_1(sender As Object, e As EventArgs) Handles NsButton2.Click
If ColorDialog2.ShowDialog() = Windows.Forms.DialogResult.OK Then
NsLabel9.Value1 = ColorDialog2.Color.R
NsLabel8.Value1 = ColorDialog2.Color.G
NsLabel7.Value1 = ColorDialog2.Color.B
NsTrackBar6.Value = NsLabel9.Value1
NsTrackBar5.Value = NsLabel8.Value1
NsTrackBar4.Value = NsLabel7.Value1
End If
End Sub
Private Sub Form1_Load(sender As Object, e As EventArgs) Handles MyBase.Load
'reads each line from the text file one at a time
For Each line As String In IO.File.ReadLines("C:\Users\Matthew\Documents\My Games\Terraria\config.json")
'split the string by equals sign
Dim ary As String() = line.Split(":")
Dim value As String = ary(0).Trim()
Dim value1 As String = ary(1).Trim()
Dim R As String
Dim G As String
Dim B As String
Dim outline As String
Dim outlineColor As String
R = Chr(34) & "MouseColorR" & Chr(34)
G = Chr(34) & "MouseColorG" & Chr(34)
B = Chr(34) & "MouseColorB" & Chr(34)
outline = Chr(34) & "ThickMouseEdges" & Chr(34)
outlineColor = Chr(34) & "ThickMouseEdgesPackedColor" & Chr(34)
'based on the value after the equals sign, do something
If value = R Then
MsgBox(ary(1).Trim(Chr(44)))
ElseIf value = G Then
MsgBox("finally")
ElseIf value = B Then
MsgBox("finally")
ElseIf value = outline Then
MsgBox("finally")
ElseIf value = outlineColor Then
MsgBox("finally")
End If
Next
End Sub
End Class

You are populating ary via Dim ary As String() = line.Split(":"). You are reading each line from C:\Users\Matthew\Documents\My Games\Terraria\config.json
One of the lines of that file doesn't contain a :. So the Split creates an array of just one element. When you then call:
Dim value1 As String = ary(1).Trim()
you get an ArgumentOutOfRangeException as element 1 doesn't exist.
The solution is to test the array length and have you code handle a line without a : in a graceful fashion.

You're accessing a container at position 0 which works and then at 1 which does not. The exception displayed in the screenshot says it's an out-of-range problem. So your container isn't as large as you expect: It has only 1 element.

Related

How do i get a loop so that for each cell in 4 columns (note each cells per column is a Criteria) it checks for the price in a database

I am writing a Excel file that can get a price form a database depending on 4 Criteria. I got to the point that it can find in one row the price (in the row there are first the 4 criteria and then the price)[See picture1]. but what i want is that every row can find the matching price. The code that i have now is this:
Option Explicit
Sub cmdSearch_Click()
Dim strCriteriaEquipment As String
Dim strCriteriaType As String
Dim strCriteriaMaterial As String
Dim strCriteriaSize As String
Dim strSQL As String
Dim strSourceTable As String
With Worksheets("Summary")
strCriteriaEquipment = .Range("B29").Value
strCriteriaType = .Range("C29").Value
strCriteriaMaterial = .Range("D29").Value
strCriteriaSize = .Range("E29").Value
End With
strSourceTable = "[DB$" & Replace(Worksheets("DB").Range("SourceData").Address, "$", "") & "]"
strSQL = "SELECT [Price] FROM " & strSourceTable & vbNewLine
strSQL = strSQL & "WHERE [Equipment]= """ & strCriteriaEquipment & """" & vbNewLine
strSQL = strSQL & "AND [Type]=""" & strCriteriaType & """" & vbNewLine
strSQL = strSQL & "AND [Material]=""" & strCriteriaMaterial & """" & vbNewLine
strSQL = strSQL & "AND [Size]=""" & strCriteriaSize & """;"
Call TableFetcher(strSQL)
strSQL = vbNullString
strCriteriaEquipment = vbNullString
strCriteriaType = vbNullString
strCriteriaMaterial = vbNullString
strCriteriaSize = vbNullString
strSourceTable = vbNullString
End Sub
Option Explicit
Public Const adOpenStatic = 3
Public Const adOpenKeySet = 1
Public Const adLockReadOnly = 1
Sub Fetcher(strSQL As String, Optional strDropDownName As String)
Dim rstRecordSet As Object 'ADODB.Recordset
Dim con As Object 'ADODB.Connection
Dim strWorkBookPath As String
strWorkBookPath = ThisWorkbook.FullName
Set con = CreateObject("ADODB.Connection")
Set rstRecordSet = CreateObject("ADODB.RecordSet")
con.Open "Provider=Microsoft.Jet.OLEDB.4.0;" & _
"Data Source=" & strWorkBookPath & ";" & _
"Extended Properties=""Excel 8.0;HDR=Yes"";"
rstRecordSet.Open strSQL, con, adOpenStatic, adLockReadOnly
With Worksheets("Summary")
With .DropDowns(strDropDownName)
.RemoveAllItems
.List = Split(UniqueStringWithDelimiter(rstRecordSet.GetRows, "|"), "|")
.Value = 1
End With
End With
rstRecordSet.Close
con.Close
Set rstRecordSet = Nothing
Set con = Nothing
strWorkBookPath = vbNullString
End Sub
Sub TableFetcher(strSQL As String)
Dim rstRecordSet As Object 'ADODB.Recordset
Dim con As Object 'ADODB.Connection
Dim strWorkBookPath As String
strWorkBookPath = ThisWorkbook.FullName
Set con = CreateObject("ADODB.Connection")
Set rstRecordSet = CreateObject("ADODB.RecordSet")
con.Open "Provider=Microsoft.Jet.OLEDB.4.0;" & _
"Data Source=" & strWorkBookPath & ";" & _
"Extended Properties=""Excel 8.0;HDR=Yes"";"
rstRecordSet.Open strSQL, con, adOpenStatic, adLockReadOnly
With Worksheets("Summary")
If Not (rstRecordSet.EOF And rstRecordSet.BOF) Then
.Range("ResultTable").Cells(5).CopyFromRecordset rstRecordSet
Else
.Range("ResultTable").Cells(5).Value = "Data Not Found!"
End If
End With
rstRecordSet.Close
con.Close
Set rstRecordSet = Nothing
Set con = Nothing
strWorkBookPath = vbNullString
End Sub
Public Function UniqueStringWithDelimiter(varArray As Variant, strDelimiter As String) As Variant
Dim varTemp() As Variant
Dim lngLoop As Long
Dim strConcat As String
ReDim Preserve varTemp(0 To 0)
varTemp(0) = varArray(0, 0)
strConcat = strConcat & varArray(0, 0)
For lngLoop = 1 To UBound(varArray, 2)
If InStr(1, strConcat, varArray(0, lngLoop), vbTextCompare) = 0 Then
strConcat = strConcat & strDelimiter & varArray(0, lngLoop)
End If
Next lngLoop
UniqueStringWithDelimiter = strConcat.
strConcat = vbNullString
Erase varTemp
End Function
How i do change the code so it does what i need it to do
What I think i'm reading is that, if four (4) criteria are met, you would then find a price. Have you used an If statement with AND modifier utilizing your four (4) criteria?
This could happen in a loop, such as:
Dim r as Long, c as Long, LR as Long
LR = Cells(Rows.Count,1).End(xlUp).Row 'Assumes column 1 is contiguous
For r = 1 to LR
c=4 'assumes you're starting with column 4
If Cells(r,c).Value="Blah" AND Cells(r,c+1).Value ="Moo" AND Cells(r,c+2).Value="Ruff" AND Cells(r,c+3).Value="Shamoo" Then
Cells(r,c+4).Copy
End If
Next r

How to refresh a Loop or update a Loop in VBA

So I have this list that is X rows long.
Each has 5 columns: Equipment, Type, Material, Size and Price this is in the Sheet2.
I also have a database in sheet1 with the same column filled in. I have written a code in VBA that for each row in Sheet2 I can fill in Equipment, Type, Material and Size and it will search in the database in sheet1 the matching price for those criteria and past this under the column Price in Sheet2.
Now the problem that I have is if I for example filled in row 1, row 2 and row 3 after each other it works and gives me the price but if I later want to change the variables in row 1 or 2 it doesn't change/update the Price but it still works for row 3 and forward.
How do I make it so that it does change/Update the price in row 1 and 2 if I change the variables there.
my code:
Option Explicit
Public r As Long
Public Const adOpenStatic = 3
Public Const adOpenKeySet = 1
Public Const adLockReadOnly = 1
Sub cmdSearch_Click()
Dim strCriteriaEquipment As String
Dim strCriteriaType As String
Dim strCriteriaMaterial As String
Dim strCriteriaSize As String
Dim strSQL As String
Dim strSourceTable As String
Dim c As Long, LR As Long
LR = Cells(Rows.Count, 2).End(xlUp).Row
For r = 1 To LR
c = 2
With Worksheets("Summary")
strCriteriaEquipment = Worksheets("Summary").Cells(r, c).Value
strCriteriaType = Worksheets("Summary").Cells(r, c + 1).Value
strCriteriaMaterial = Worksheets("Summary").Cells(r, c + 2).Value
strCriteriaSize = Worksheets("Summary").Cells(r, c + 3).Value
End With
Next r
strSourceTable = "[DB$" & Replace(Worksheets("DB").Range("SourceData").Address, "$", "") & "]"
strSQL = "SELECT [Price] FROM " & strSourceTable & vbNewLine
strSQL = strSQL & "WHERE [Equipment]= """ & strCriteriaEquipment & """" & vbNewLine
strSQL = strSQL & "AND [Type]=""" & strCriteriaType & """" & vbNewLine
strSQL = strSQL & "AND [Material]=""" & strCriteriaMaterial & """" & vbNewLine
strSQL = strSQL & "AND [Size]=""" & strCriteriaSize & """;"
Dim rstRecordSet As Object 'ADODB.Recordset
Dim con As Object 'ADODB.Connection
Dim strWorkBookPath As String
strWorkBookPath = ThisWorkbook.FullName
Set con = CreateObject("ADODB.Connection")
Set rstRecordSet = CreateObject("ADODB.RecordSet")
con.Open "Provider=Microsoft.Jet.OLEDB.4.0;" & _
"Data Source=" & strWorkBookPath & ";" & _
"Extended Properties=""Excel 8.0;HDR=Yes"";"
rstRecordSet.Open strSQL, con, adOpenStatic, adLockReadOnly
With Worksheets("Summary")
For r = r - 29 To LR
c = 5
If Not (rstRecordSet.EOF And rstRecordSet.BOF) Then
.Range("ResultTable").Cells(r, c).CopyFromRecordset rstRecordSet
Else
.Range("ResultTable").Cells(r, c).Value = "Data Not Found!"
End If
Next r
End With
rstRecordSet.Close
con.Close
Set rstRecordSet = Nothing
Set con = Nothing
strWorkBookPath = vbNullString
strSQL = vbNullString
strCriteriaEquipment = vbNullString
strCriteriaType = vbNullString
strCriteriaMaterial = vbNullString
strCriteriaSize = vbNullString
strSourceTable = vbNullString
End Sub
Public Function UniqueStringWithDelimiter(varArray As Variant, strDelimiter As String) As Variant
Dim varTemp() As Variant
Dim lngLoop As Long
Dim strConcat As String
ReDim Preserve varTemp(0 To 0)
varTemp(0) = varArray(0, 0)
strConcat = strConcat & varArray(0, 0)
For lngLoop = 1 To UBound(varArray, 2)
If InStr(1, strConcat, varArray(0, lngLoop), vbTextCompare) = 0 Then
strConcat = strConcat & strDelimiter & varArray(0, lngLoop)
End If
Next lngLoop
UniqueStringWithDelimiter = strConcat.
strConcat = vbNullString
Erase varTemp
End Function
Now to update everytime I change something in Sheet2 I just wrote this:
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Call cmdSearch_Click
End Sub
So again my question how do I update/change the price if I change a variable in row 1 or row 2 if row 3 was the last row that was used in the sheet.
This is the datbase that I am using:
This is Sheet2:
1) One immediate problem I see that will cause your issue (and there may be more, but I don't have time to dissect so much at this moment), is that the initial loop:
For r = 1 To LR
c = 2
With Worksheets("Summary")
strCriteriaEquipment = Worksheets("Summary").Cells(r, c).Value
strCriteriaType = Worksheets("Summary").Cells(r, c + 1).Value
strCriteriaMaterial = Worksheets("Summary").Cells(r, c + 2).Value
strCriteriaSize = Worksheets("Summary").Cells(r, c + 3).Value
End With
Next r
is not doing what you may expect. At the end of this loop you only have set the values for the last row of data (I suspect row 3) to pass into your query.
You'll need to write your queries inside this loop as well so that the query is run for each set of criteria in each line.
For example:
For r = 1 to LR
c = 2
With Worksheets("Summary")
'code to set criteria
End With
'code to download data price
'code to stick data and price in summary tab
Next r
2) Also, make sure to qualify all your objects. The line
LR = Cells(Rows.Count, 2).End(xlUp).Row
may return different results if the sheet you desire to be active is not actually active. Better to say this, for example, and leave out guess works:
LR = Worksheets("Summary").Cells(Rows.Count, 2).End(xlUp).Row
3) Using Worksheet_SelectionChange will fire your code every time you move from one to another in your worksheet. If you want to only fire the code when you make a change to the criteria in your data, use Worksheet_Change instead. You can also define which specific cells being changes will run the code as well.

saving userform inputs in an array

I'm trying to use userforms in word VBA to save an undefined number of variables into an array to later input in a document but I can't get the incremental counter to work and it will only save the last input and it is saved as input 0.
Public i As Integer
Sub Macro6()
UF1.Show
End Sub
Private Sub btnAddC_Click()
Dim CName(100) As String
Dim CAddress(100) As String
CName(i) = txtName.Text
CAddress(i) = txtAddress.Text
i = i + 1
Unload Me
UF1.Show
End Sub
Private Sub btnNext_Click()
Dim CName(100) As String
Dim CAddress(100) As String
Dim n As Integer
CName(i) = txtName.Text
CAddress(i) = txtAddress.Text
Unload Me
For n = 0 To i
Selection.TypeText Text:="Client number " & n & " is " & CName(n) & "."
Selection.TypeParagraph
Selection.TypeText Text:="Client number " & n & " is " & CAddress(n) & "."
Selection.TypeParagraph
Next
End Sub
Private Sub UserForm_Initialize()
txtName.Text = ""
txtAddress.Text = ""
End Sub
The output is always:
Client number 0 is a.
Client number 0 is b.

Deleting directory in an array

I have this code that gets all file types.
Dim file as variant
file = Application.GetOpenFilename("All Files, *.*", , "Select File", , True)
Then I have to print it in the cells on a sheet.
For i = 1 To UBound(file)
lRow = Cells(Rows.count, 15).End(xlUp).Row
lRow = lRow + 1
ThisWorkbook.Sheets("Main").Range("O" & lRow).Value = CStr(file(i))
Next i
but what I want is first check the contents of the array. If the array has this file type, then I have to remove it in the arraylist. After that, a message will pop out that this files are removed.
dim arr() as string
arr = Split("ade|adp|app|asp|bas|bat|cer|chm|cmd|com|cpl|crt|csh|der|exe|fxp|gadget|hlp|hta|inf|ins|isp|its|js|jse|" _
& "ksh|lnk|mad|maf|mag|mam|maq|mar|mas|mat|mau|mav|maw|mda|mdb|mde|mdt|mdw|mdz|msc|msh|msh1|msh2|" _
& "mshxml|msh1xml|msh2xml|ade|adp|app|asp|bas|bat|cer|chm|cmd|com|cpl|crt|csh|der|exe|fxp|gadget|hlp|" _
& "hta|msi|msp|mst|ops|pcd|pif|plg|prf|prg|pst|reg|scf|scr|sct|shb|shs|ps1|ps1xml|ps2|ps2xml|psc1|psc2|tmp|url|vb|vbe|vbs|vsmacros|vsw|ws|wsc|wsf|wsh|xnk", "|")
I just don't know where I have to start. I have found a little bit same problem here in this post, but I just can't understand it. Thanks!
You can use a RegExp and a varaint array to do this quickly
This code looks for path... dot extension end string so it is more robust than your current array which may remove files based on the path name rather than file type
Sub B()
Dim fName As Variant
Dim objRegex As Object
Dim lngCnt As Long
Dim rng1 As Range
Set objRegex = CreateObject("vbscript.regexp")
On Error Resume Next
fName = Application.GetOpenFilename("All Files, *.*", , "Select file", , True)
If Err.Number <> 0 Then Exit Sub
On Error GoTo 0
With objRegex
.Pattern = ".*\.(ade|adp|app|asp|bas|bat|cer|chm|cmd|com|cpl|crt|csh|der|exe|fxp|gadget|hlp|hta|inf|ins|isp|its|js|jse|" _
& "ksh|lnk|mad|maf|mag|mam|maq|mar|mas|mat|mau|mav|maw|mda|mdb|mde|mdt|mdw|mdz|msc|msh|msh1|msh2|" _
& "mshxml|msh1xml|msh2xml|ade|adp|app|asp|bas|bat|cer|chm|cmd|com|cpl|crt|csh|der|exe|fxp|gadget|hlp|" _
& "hta|msi|msp|mst|ops|pcd|pif|plg|prf|prg|pst|reg|scf|scr|sct|shb|shs|ps1|ps1xml|ps2|ps2xml|psc1|psc2|tmp|url|vb|vbe|vbs|vsmacros|vsw|ws|wsc|wsf|wsh|xnk)$"
`replace matching file types with blank array entries
For lngCnt = 1 To UBound(fName)
fName(lngCnt) = .Replace(fName(lngCnt), vbNullString)
Next
End With
Set rng1 = Cells(Rows.Count, 15).End(xlUp).Offset(1,0)
'dump array to sheet
rng1.Resize(UBound(fName), 1) = Application.Transpose(fName)
` remove blank entries
On Error Resume Next
rng1.SpecialCells(xlCellTypeBlanks).Delete xlUp
On Error GoTo 0
End Sub
One way would be to check that the extension it's not present in the blacklist with InStr:
Const exts = _
".ade.adp.app.asp.bas.bat.cer.chm.cmd.com.cpl.crt.csh.der.exe.fxp.gadget" & _
".hlp.hta.inf.ins.isp.its.js.jse.ksh.lnk.mad.maf.mag.mam.maq.mar.mas.mat" & _
".mau.mav.maw.mda.mdb.mde.mdt.mdw.mdz.msc.msh.msh1.msh2.mshxml.msh1xml" & _
".msh2xml.ade.adp.app.asp.bas.bat.cer.chm.cmd.com.cpl.crt.csh.der.exe.fxp" & _
".gadget.hlp.hta.msi.msp.mst.ops.pcd.pif.plg.prf.prg.pst.reg.scf.scr.sct" & _
".shb.shs.ps1.ps1xml.ps2.ps2xml.psc1.psc2.tmp.url.vb.vbe.vbs.vsmacros.vsw" & _
".ws.wsc.wsf.wsh.xnk."
Dim file As Variant
file = Application.GetOpenFilename("All Files, *.*", , "Select File", , True)
Dim i As Long, data(), count As Long, ext As String
ReDim data(1 To UBound(file) + 1, 1 To 1)
' filter the list
For i = LBound(file) To UBound(file)
ext = LCase(Mid(file(i), InStrRev(file(i), ".")))
If InStr(1, exts, ext & ".") = 0 Then ' if not blacklisted
count = count + 1
data(count, 1) = file(i)
End If
Next
' copy the filtered list to the next available row in column "O"
If count Then
With ThisWorkbook.Sheets("Main").Cells(Rows.count, "O").End(xlUp)
.Offset(1).Resize(count).Value = data
End With
End If

move string from array to new sheet

The code below break the cells in image 1 into an array pictured in image 2. The new array is moved to start at AG. After that the program looks through the array and finds the words 'hello' and 'bye'. It takes those words and moves them into a new sheet and column pictured in image 3. Where I'm having trouble is that I want to still pull the strings 'hello' and 'bye' but I want to also pull the string directly before it from the array. In my example (image 3) I would've wanted it to read 'John Hello' instead of 'hello' on its own. What function would I use to extract the string before 'hello' or 'bye' also from the array?
Sub SplitWithFormat()
Dim R As Range, C As Range
Dim i As Long, V As Variant
Dim varHorizArray As Variant
Dim rge As Range
Dim intCol As Integer
Dim s As String
Set R = Range("d1", Cells(Rows.Count, "d").End(xlUp))
For Each C In R
With C
.TextToColumns Destination:=.Range("AD1"), DataType:=xlDelimited, _
consecutivedelimiter:=True, Tab:=False, semicolon:=True, comma:=False, _
Space:=True, other:=True, Otherchar:=vbLf
Set rge = Selection
varHorizArray = rge
.Copy
Range(.Range("AD1"), Cells(.Row, Columns.Count).End(xlToLeft)).PasteSpecial xlPasteFormats
End With
Next C
Application.CutCopyMode = False
For intCol = LBound(varHorizArray, 2) To UBound(varHorizArray, 2)
Debug.Print varHorizArray(1, intCol)
Next intCol
With Application
.ScreenUpdating = False
.EnableEvents = False
End With
varHorizArray = Array("hello", "bye")
Set NewSh = Worksheets.Add
With Sheets("Sheet2").Range("AD1:AZ100")
Rcount = 0
For i = LBound(varHorizArray) To UBound(varHorizArray)
Set Rng = .find(What:=varHorizArray(i), _
After:=.Cells(.Cells.Count), _
LookIn:=xlFormulas, _
LookAt:=xlPart, _
SearchOrder:=xlByRows, _
SearchDirection:=xlNext, _
MatchCase:=False)
If Not Rng Is Nothing Then
FirstAddress = Rng.Address
Do
Rcount = Rcount + 1
Rng.Copy NewSh.Range("A" & Rcount)
NewSh.Range("A" & Rcount).Value = Rng.Value
Set Rng = .FindNext(Rng)
Loop While Not Rng Is Nothing And Rng.Address <> FirstAddress
End If
Next i
End With
With Application
.ScreenUpdating = True
.EnableEvents = True
End With
End Sub​​
Option Explicit
Sub Tester()
Dim c As Range, v As String, arr, x As Long, e
Dim d As Range
'EDIT: changed destination for results
Set d = WorkSheets("Sheet2").Range("D2") '<<results start here
For Each c In ActiveSheet.Range("A2:A10")
v = Trim(c.Value)
If Len(v) > 0 Then
'normalize other separators to spaces
v = Replace(v, vbLf, " ")
'remove double spaces
Do While InStr(v, " ") > 0
v = Replace(v, " ", " ")
Loop
'split to array
arr = Split(v, " ")
For x = LBound(arr) To UBound(arr)
e = arr(x)
'see if array element is a word of interest
If Not IsError(Application.Match(LCase(e), Array("hello", "bye"), 0)) Then
If x > LBound(arr) Then
d.Value = arr(x - 1) & " " & e 'prepend previous word
Else
d.Value = "??? " & e 'no previous word
End If
Set d = d.Offset(1, 0)
End If
Next x
End If
Next c
End Sub
Something like this?
Option Explicit
Sub strings()
Dim ws As Worksheet
Dim rng As Range
Dim cell As Range
Dim lookingForThese() As String
Set ws = ThisWorkbook.Worksheets(1)
Set rng = ws.Range(ws.Range("A1"), ws.Range("A1").End(xlDown))
ReDim lookingForThese(1 To 2)
lookingForThese(1) = "bye"
lookingForThese(2) = "hello"
For Each cell In rng
Dim i As Integer
Dim parts() As String
'Split the string in the cell
parts = Split(cell.Value, " ")
'I'm parsing the parts to a 2. worksheet and the hello/bye + the word before those on a 3.
For i = LBound(parts) To UBound(parts)
Dim j As Integer
ThisWorkbook.Worksheets(2).Cells(cell.Row, i + 1).Value = parts(i)
For j = LBound(lookingForThese) To UBound(lookingForThese)
If parts(i) = lookingForThese(j) Then
If i <> LBound(parts) Then
ThisWorkbook.Worksheets(3).Cells(cell.Row, 1).Value = parts(i - 1) & " " & parts(i)
Else
ThisWorkbook.Worksheets(3).Cells(cell.Row, 1).Value = parts(i)
End If
End If
Next j
Next i
Next cell
End Sub

Resources