The formula expression of cells have structure similar to this:
= A12 +B12- C1234 + E18 + CustomCellName1+D12 - H6- U8 - CustomCellName2
+ CustomCellName3 + CustomCellName4- CustomCellName5 + G7
How can we scrub the variables with at most five characters such that the formula will be:
= CustomCellName1-CustomCellName2+CustomCellName3+CustomCellName4-CustomCellName5
Thanks
The formula expression of cells are of these forms:
= A12 + B12 + C1234 + CustomCellName1 + CustomCellName3 + CustomCellName3
Thanks but its either a + or - or a combination of both – John Snow 12 mins ago
If they are of this form then it is simple.
Option Explicit
Sub Sample()
Dim Ar
Dim i As Long
Dim NewFormula As String
Dim ws As Worksheet
'~~> Change this to relevent sheet and range
Set ws = Sheet1
Ar = Split(ws.Range("A1").Formula)
For i = LBound(Ar) To UBound(Ar)
'~~> > 1 to preserve +
If Len(Trim(Ar(i))) > 1 And Len(Ar(i)) < 6 Then Ar(i) = ""
Next i
NewFormula = Join(Ar, "")
Do While InStr(1, NewFormula, "++") Or _
InStr(1, NewFormula, "--") Or _
InStr(1, NewFormula, "+-") Or _
InStr(1, NewFormula, "-+")
NewFormula = Replace(NewFormula, "++", "+")
NewFormula = Replace(NewFormula, "+-", "-")
NewFormula = Replace(NewFormula, "-+", "+")
NewFormula = Replace(NewFormula, "--", "-")
Loop
NewFormula = Replace(NewFormula, "=+", "=")
NewFormula = Replace(NewFormula, "=-", "=")
Debug.Print NewFormula
'ws.Range("A1").Formula = NewFormula
End Sub
But if they are not and involve operator other that "+" and also involve Excel Functions then it may not be easy.
Related
I am trying to split cell strings into various cells in one Excel spread sheet and then copy and paste the split cells with new headings into a new sheet. Below is the image of what I am trying to split.
What I am trying to split
Here is what I am trying to achieve.
Wanted Outcome.
Unfortunately I am new to stackoverflow so my images wont show. If users do not wish to click the link I will try explain by other means:
I have various cells which contain long strings which I am trying to split.
Below is an example of two rows which I would like to split.
Setup | MC 1: 1 x 18 , MC 2: 2 x 23 , MC 3: 2 x 32|
------------|----------------------------------------------
Microphone | 2 x PHILIP DYNAMI SBMCMD |
(where | represents a column break)
I would like to split the above with the following headers as shown below.
Setup | |Speaker|Tables|People|Speaker|Tables|People|Speaker|Tables|People|
----------------------------------------------------------------------------------
| | MC1 | 1 | 18 | MC2 | 2 | 23 | MC3 | 2 | 32 |
--------------------------------------------------------------------------------------
| | | | | | | | |
---------------------------------------------------------------------------------------
Microphone | |Number |Manufc| Model|MdlNum |
---------------------------------------------------------------------------
| | 2 |PHILIP|DYNAMI|SBMCMD |
The following code works for the setup rows. However it does not work for the microphone rows. It manages to split the correct delimiter, however it does not target the correct row containing the Microphone data.
Sub Sample()
Dim MYAr, setup
Dim MicAr, Mic
Dim ws As Worksheet, wsOutput As Worksheet
Dim Lrow As Long, i As Long, j As Long, rw As Long, col As Long, Rrow As Long
Dim arrHeaders
Dim arrayHeadersMic
Set ws = ThisWorkbook.Sheets("Sheet1") '~~> Set this to the relevant worksheet
'Set wsOutput = ThisWorkbook.Sheets.Add '~~> Add a new worksheet for output
Set wsOutput = ThisWorkbook.Sheets("Sheet2")
rw = 2 '<< output starts on this row
arrHeaders = Array("Speaker", "Tables", "People")
arrHeadersMic = Array("Number", "Manufacturer", "Model", "Model Number")
With ws
Lrow = .Range("B" & .Rows.Count).End(xlUp).Row '~~> get the last row
For i = 1 To Lrow
If .Cells(i, 1).Value = "Setup" Then
wsOutput.Cells(rw, 1).Value = "Setup"
wsOutput.Cells(rw + 3, 1).Value = "Microphone"
setup = .Range("B" & i).Value
If Len(setup) > 0 Then 'Len Returns an integer containing either the number of characters in a string or the nominal number of bytes required to store a variable.
MYAr = SetupToArray(setup)
'add the headers
wsOutput.Cells(rw, 3).Resize(1, 3).Value = arrHeaders
wsOutput.Cells(rw + 3, 3).Resize(1, 4).Value = arrHeadersMic
'fill headers across
wsOutput.Cells(rw, 3).Resize(1, 3).AutoFill _
Destination:=wsOutput.Cells(rw, 3).Resize(1, UBound(MYAr) + 1)
'populate the array
wsOutput.Cells(rw + 1, 3).Resize(1, UBound(MYAr) + 1).Value = MYAr
'figure out the microphone values here....
Lrow = .Range("B" & .Rows.Count).End(xlUp).Row
If .Cells(5, 1).Value = "Microphone" Then
setup = 0
Mic = .Range("B" & i).Value
'If Len(Mic) > 0 Then
MicAr = MicToArray(Mic)
'fill headers across
wsOutput.Cells(rw + 3, 3).Resize(1, 4).AutoFill _
Destination:=wsOutput.Cells(rw + 3, 3).Resize(1, UBound(MicAr) + 1) 'UBound Returns the highest available subscript for the indicated dimension of an array.
'populate the array
wsOutput.Cells(rw + 4, 3).Resize(1, UBound(MicAr) + 1).Value = MicAr
'End If
End If
rw = rw + 7
End If
End If
Next i
End With
End Sub
Function SetupToArray(v)
Dim MYAr, i
v = Replace(v, ":", ",")
v = Replace(v, " x ", ",")
MYAr = Split(v, ",")
'trim spaces...
For i = LBound(MYAr) To UBound(MYAr)
MYAr(i) = Trim(MYAr(i))
Next i
SetupToArray = MYAr
End Function
Function MicToArray(w)
Dim MicAr, i
w = Replace(w, " x ", " ")
'w = Replace(w, " ", ",")
MicAr = Split(w, " ")
'trimspace
For i = LBound(MicAr) To UBound(MicAr)
MicAr(i) = Trim(MicAr(i))
Next i
MicToArray = MicAr
End Function
Thank you in advance for your help!
EDIT: updated and tested - works for your "setup" data
Sub Sample()
Dim MYAr, setup
Dim ws As Worksheet, wsOutput As Worksheet
Dim Lrow As Long, i As Long, j As Long, rw As Long, col As Long
Dim arrHeaders
Set ws = ThisWorkbook.Sheets("Sheet1") '~~> Set this to the relevant worksheet
Set wsOutput = ThisWorkbook.Sheets.Add '~~> Add a new worksheet for output
rw = 2 '<< output starts on this row
arrHeaders = Array("Speaker", "Tables", "People")
With ws
Lrow = .Range("B" & .Rows.Count).End(xlUp).Row '~~> get the last row
For i = 1 To Lrow
If .Cells(i, 1).Value = "Setup" Then
wsOutput.Cells(rw, 1).Value = "Setup"
wsOutput.Cells(rw + 1, 1).Value = "Microphone"
setup = .Range("B" & i).Value
If Len(setup) > 0 Then
MYAr = SetupToArray(setup)
'add the headers
wsOutput.Cells(rw, 3).Resize(1, 3).Value = arrHeaders
'fill headers across
wsOutput.Cells(rw, 3).Resize(1, 3).AutoFill _
Destination:=wsOutput.Cells(rw, 3).Resize(1, UBound(MYAr) + 1)
'populate the array
wsOutput.Cells(rw + 1, 3).Resize(1, UBound(MYAr) + 1).Value = MYAr
'figure out the microphone values here....
rw = rw + 6
End If
End If
Next i
End With
End Sub
Function SetupToArray(v)
Dim MYAr, i
v = Replace(v, ":", ",")
v = Replace(v, " x ", ",")
MYAr = Split(v, ",")
'trim spaces...
For i = LBound(MYAr) To UBound(MYAr)
MYAr(i) = Trim(MYAr(i))
Next i
SetupToArray = MYAr
End Function
Easier to copy the range to the Windows Clipboard and use the TSV Text format (not tested):
Sheet1.Cells.Copy ' copy the range
With CreateObject("New:{1C3B4210-F441-11CE-B9EA-00AA006B1A69}") ' this is late bound MSForms.DataObject
Dim s As String
.GetFromClipboard ' get the formats from the Windows Clipboard
s = .GetText ' get the "Text" format
Application.CutCopyMode = False
' magic
s = Replace(s, "MC ", "MC") ' "MC 1" to "MC1"
s = Replace(s, " x ", "|") ' "1 x 18" to "1|18"
s = Replace(s, " , ", "|") ' "18 , MC" to "18|MC"
s = Replace(s, ": ", "|") ' "MC1: 1" to "MC1|1"
s = Replace(s, " ", "|") ' "2|PHILIP DYNAMI SBMCMD" to "2|PHILIP|DYNAMI|SBMCMD"
' "more magic"
s = Replace(s, "Setup" & vbTab, "/Setup||Speaker|Tables|People|Speaker|Tables|People|Speaker|Tables|People/||")
s = Replace(s, "Microphone" & vbTab, "/Microphone||Number|manufacturer|Model|Model Num/||")
s = Replace(s, "|", vbTab) ' cells are separated by tab
s = Replace(s, "/", vbNewLine) ' rows are separated by new line
.SetText s
.PutInClipboard
End With
Sheet2.PasteSpecial "Text" ' or Sheet2.Range("A1").PasteSpecial
I have the following VBA code:
Sub test():
Dim NameValue As String, w1 As Worksheet, w2 As Worksheet
Dim i As Long, j As Long, k As Long, c As Long
Set w1 = Sheets("Sheet2"): Set w2 = Sheets("Sheet3")
GetNameValue: For i = 1 To w1.Range("A" & Rows.Count).End(xlUp).row
If w1.Range("A" & i) = "NAME:" Then
If InStr(1, NameValue, w1.Range("B" & i)) Then GoTo GetNext
j = i + 1: Do Until w1.Range("A" & j) = "DATE OF BIRTH:": j = j + 1: Loop
NameValue = Trim(NameValue & " " & w1.Range("B" & i) & "|" & w1.Range("B" & j))
c = c + 1: End If
GetNext: Next i: NameValue = NameValue & " "
For k = 1 To c
i = InStr(1, NameValue, "|"): j = InStr(i, NameValue, " ")
w2.Range("A" & k) = Left(NameValue, i - 1): w2.Range("B" & k) = Mid(NameValue, i + 1, j - i)
NameValue = Mid(NameValue, j + 1, Len(NameValue) - j)
Next k
End Sub
To break down what this code does:
1) Set the first sheet that should be searched and the second sheet (output sheet) that the results should be appended to.
2) Search the first column for a certain string "NAME:" and once found take the value in the second column, place it in the output sheet go look for "DATE OF BIRTH:". Once "DATE OF BIRTH:" is found put it beside the value for "NAME:" in the output sheet.
3) Repeat until there are no more entries.
I'm sure this is a very simple modification, but what I'd like to do is check whether a certain string exists, if it does grab the entry directly BELOW it, and then continue searching for the next string and associated entry just like the code does already.
Can anyone point me to what I would need to change in order to do this (and preferably why)?
In addition, how might I be able to extend this code to run over multiple sheets while depositing the results in a single sheet? Do I need to set up a range running over the worksheets w_1....w_(n-1) (with output sheet w_n possibly in a different workbook)?
Removed Line continuations in code:
Sub test()
Dim NameValue As String, w1 As Worksheet, w2 As Worksheet
Dim i As Long, j As Long, k As Long, c As Long
Set w1 = Sheets("Sheet2")
Set w2 = Sheets("Sheet3")
GetNameValue:
For i = 1 To w1.Range("A" & Rows.Count).End(xlUp).Row
If w1.Range("A" & i) = "NAME:" Then
If InStr(1, NameValue, w1.Range("B" & i)) Then GoTo GetNext
j = i + 1
Do Until w1.Range("A" & j) = "DATE OF BIRTH:"
j = j + 1
Loop
NameValue = Trim(NameValue & " " & w1.Range("B" & i) & "|" & w1.Range("B" & j))
c = c + 1
End If
GetNext:
Next i
NameValue = NameValue & " "
For k = 1 To c
i = InStr(1, NameValue, "|")
j = InStr(i, NameValue, " ")
w2.Range("A" & k) = Left(NameValue, i - 1)
w2.Range("B" & k) = Mid(NameValue, i + 1, j - i)
NameValue = Mid(NameValue, j + 1, Len(NameValue) - j)
Next k
End Sub
UPDATE: Just to make sure we're all on the same page about what the output would look like. Suppose we are searching for the entry below A and the entry beside C:
INPUT
A 1
B
y 3
z 4
t
d
s 7
C 8
A 1
Z
y 3
z 4
t
d
s 7
C 12
OUTPUT
B 8
Z 12
.
.
.
Assuming I understand your desire correctly, you can use the .Offset method with your current range to get to the cell below it. You would need to add a dim, so here's my stab at what you're trying to accomplish:
Sub test()
Dim NameValue As String, w1 As Worksheet, w2 As Worksheet
'new local variable
Dim newValue as string
Dim i As Long, j As Long, k As Long, c As Long
Set w1 = Sheets("Sheet2")
Set w2 = Sheets("Sheet3")
GetNameValue:
For i = 1 To w1.Range("A" & Rows.Count).End(xlUp).Row
'assuming your string is in column A
If w1.Range("A" & i) = "FIND ME" Then
newValue = w1.Range("A" & i).Offset(1,0).Value
End If
If w1.Range("A" & i) = "NAME:" Then
If InStr(1, NameValue, w1.Range("B" & i)) Then GoTo GetNext
j = i + 1
Do Until w1.Range("A" & j) = "DATE OF BIRTH:"
j = j + 1
Loop
NameValue = Trim(NameValue & " " & w1.Range("B" & i) & "|" & w1.Range("B" & j))
c = c + 1
End If
GetNext:
Next i
NameValue = NameValue & " "
For k = 1 To c
i = InStr(1, NameValue, "|")
j = InStr(i, NameValue, " ")
w2.Range("A" & k) = Left(NameValue, i - 1)
w2.Range("B" & k) = Mid(NameValue, i + 1, j - i)
NameValue = Mid(NameValue, j + 1, Len(NameValue) - j)
Next k
End Sub
Then you could do anything you desired with the newValue string, including putting it in w2 like so: w2.Range("D1").value = newValue
UPDATED ANSWER
I am now 89% sure I know what you are trying to accomplish :) thanks for your clarifying example.
To search a range for your search string, you need to set up a range you are looking in:
dim searchRange as range
dim w1,w2 as worksheet
Set w1 = Sheets("Sheet1")
Set w2 = Sheets("Sheet2")
set searchRange = w1.Range("A" & Rows.Count).End(xlUp).Row
Then you search the searchRange for both of your search strings (which I'm saying are "A" for the first and "C" for the second). As long as both strings are found in the searchRange, it will create a new Dictionary entry for the two values, having the value below "A" as the key and the value beside "C" as the item.
dim rng as range
dim valueBelowFirstSearch as string
dim resultsDictionary as object
dim i as integer
dim c, d as range
dim cAddress, dAddress as string
set resultsDictionary = CreateObject("scripting.dictionary")
with searchRange
set c = .Find("A", lookin:=xlValues)
set d = .Find("C", lookin:=xlValues)
if not c Is Nothing and not d Is Nothing then
cAddress = c.address
dAddress = d.address
resultsDictionary.add Key:=c.offset(1,0).value, Item:=d.value
Do
set c = .FindNext(c)
set d = .FindNext(d)
Loop While not c is nothing and not d is nothing and c.address <> cAddress and d.address <> dAddress
end if
end with
Now that we have all of the results in the resultsDictionary, we can now output the values into another place, which I'm choosing to be w2.
dim outRange as range
dim item as variant
set outRange = w2.Range("A1")
for each item in resultsDictionary
outRange.Value = item.key
set outRange = outRange.Offset(0,1)
outRange.Value = item.item
set outRange = outRange.Offset(1,-1)
next item
Can anyone point me to what I would need to change in order to do this
(and preferably why)?
Basically you need to change the parts of which NameValue is composed.
Originally you took the value beside the first match as w1.Range("B" & i) and now you want the value below the first match, which is w1.Range("A" & i + 1).
Originally it was:
Trim(NameValue & " " & w1.Range("B" & i) & "|" & w1.Range("B" & j))
Now you need something like this:
Trim(NameValue & " " & w1.Range("A" & i + 1) & "|" & w1.Range("B" & j))
In addition, how might I be able to extend this code to run over
multiple sheets while depositing the results in a single sheet?
(with output sheet w_n possibly in a different workbook)?
To achieve that you can e.g. create an array of Sheets and let the code run for each Sheet of this array. Note that the array might contain 1-N Sheets.
' Set array of sheets for just one sheet
Dim searchedSheets As Sheets
Set searchedSheets = Workbooks("SomeBook.xlsx").Sheets(Array("Sheet1"))
' Set array of sheets for more sheets, e.g. "Sheet1" and "Sheet2" and "Sheet3"
Dim searchedSheets As Sheets
Set searchedSheets = Workbooks("SomeBook.xlsx").Sheets(Array("Sheet1", "Sheet2", "Sheet3"))
' Finally set the second sheet where the results should be appended
' to sheet in the same workbook as the searched sheets
Dim outputSheet As Worksheet
Set outputSheet = Workbooks("SomeBook.xlsx").Worksheets("ResultSheet")
' Or set the second sheet where the results should be appended to sheet
' in a different workbook then the searched sheets belong to
Dim outputSheet As Worksheet
Set outputSheet = Workbooks("SomeOtherBook.xlsx").Worksheets("ResultSheet")
The complete code might look like this (tested with data you provided).
Option Explicit
Public Sub main()
' String to search below of it
Dim string1 As String
string1 = "A"
' String to search beside of it
Dim string2 As String
string2 = "C"
' Set the sheets that should be searched
Dim searchedSheets As Sheets
Set searchedSheets = Workbooks("SomeBook.xlsx").Sheets(Array("Sheet1", "Sheet2"))
' Set the second sheet (outputSheet sheet) that the results should be
' appended to external sheet in different book
Dim outputSheet As Worksheet
Set outputSheet = Workbooks("SomeOtherBook.xlsx").Worksheets("ResultSheet")
SearchFor string1, string2, searchedSheets, outputSheet
End Sub
Public Sub SearchFor( _
string1 As String, _
string2 As String, _
searchedSheets As Sheets, _
output As Worksheet)
Dim searched As Worksheet
Dim NameValue As String
Dim below As String
Dim beside As String
Dim i As Long
Dim j As Long
Dim k As Long
Dim c As Long
Dim rowsCount As Long
For Each searched In searchedSheets
rowsCount = searched.Range("A" & Rows.Count).End(xlUp).Row
For i = 1 To rowsCount
' Search the first column for a 'string1'
If searched.Range("A" & i) = string1 Then
' once 'string1' was found grab the entry directly below it
below = searched.Range("A" & i + 1)
If InStr(1, NameValue, below) Then
' skip this 'below' result because it was found before
GoTo GetNext
End If
' Search the first column for a 'string2' starting at the
' position where 'below' was found
For j = i + 1 To rowsCount
If searched.Range("A" & j) = string2 Then
' once 'string2' was found grab the entry directly
' beside it
beside = searched.Range("B" & j)
Exit For
End If
Next j
' Append 'below' and 'beside' to the result and count the
' number of metches
NameValue = Trim(NameValue & " " & below & "|" & beside)
c = c + 1
End If
GetNext:
Next i
Next searched
' Write the output
NameValue = NameValue & " "
For k = 1 To c
i = InStr(1, NameValue, "|")
j = InStr(i, NameValue, " ")
output.Range("A" & k) = Left(NameValue, i - 1)
output.Range("B" & k) = Mid(NameValue, i + 1, j - i)
NameValue = Mid(NameValue, j + 1, Len(NameValue) - j)
Next k
End Sub
Note: I replaced the Do-Until loop with For-Next loop because the Do-Until might cause a Stack-Overflow :-) error if the string "DATE OF BIRTH:" does not exist in the first column. However I have tryied to keep your originall code structure so you still understand it. HTH.
Assuming that you want to find one value (Name:), then continue searching till to find the second one (Date Of Birth:)... Finally, you want to move these pair of data into another worksheet.
To achieve that, i'd suggest to use Dictionary object to get only distinct values. I strongly do not recommend to use string concatenation as you provided in your code!
Option Explicit
Sub Test()
Dim src As Worksheet, dst As Worksheet
Set dst = ThisWorkbook.Worksheets("Sheet2")
For Each src In ThisWorkbook.Worksheets
If src.Name = dst.Name Then GoTo SkipNext
NamesToList src, dst
SkipNext:
Next
End Sub
'needs reference to MS Scripting Runtime library
Sub NamesToList(ByVal srcWsh As Worksheet, ByVal dstWsh As Worksheet, _
Optional ByVal SearchFor As String = "NAME:", Optional ByVal ThenNextFor As String = "DATE OF BIRTH:")
Dim dic As Dictionary, i As Long, j As Long, k As Long
Dim sKey As String, sVal As String
On Error GoTo Err_NamesToList
Set dic = New Dictionary
i = 2
j = GetFirstEmpty(srcWsh)
Do While i < j
If srcWsh.Range("A" & i) = SearchFor Then
sKey = srcWsh.Range("B" & i)
If Not dic.Exists(sKey) Then
Do While srcWsh.Range("A" & i) <> ThenNextFor
i = i + 1
Loop
sVal = srcWsh.Range("B" & i)
dic.Add sKey, sVal
k = GetFirstEmpty(dstWsh)
With dstWsh
.Range("A" & k) = sKey
.Range("B" & k) = sVal
End With
'sKey = ""
'sVal = ""
End If
End If
SkipNext:
i = i + 1
Loop
Exit_NamesToList:
On Error Resume Next
Set dic = Nothing
Exit Sub
Err_NamesToList:
Resume Exit_NamesToList
End Sub
Function GetFirstEmpty(ByVal wsh As Worksheet, Optional ByVal sCol As String = "A") As Long
GetFirstEmpty = wsh.Range(sCol & wsh.Rows.Count).End(xlUp).Row + 1
End Function
Sample output:
Name DateOfBirth:
A 1999-01-01
B 1999-01-02
C 1999-01-03
D 1999-01-04
E 1999-01-05
i have in A column some names and in b column some numbers like:
jimmy 4
jimmy 4
carl 8
john 8
I need to sum jimmy's numbers. I mean, if there are some same values in A colum the sum the B numbers of that name. So jimmy = 8.
How can i do it? I'm very new in vba so the easy things for me are not so easy :)
EDIT, the macro:
Sub Sample()
Dim path As String
Dim openWb As Workbook
Dim openWs As Worksheet
Dim DataInizio As String
Dim DataFine As String
path = "C:\Me\Desktop\example.xls"
Set thiswb = ThisWorkbook
Set openWb = Workbooks.Open(path)
Set openWs = openWb.Sheets("details")
Set Logore = thiswb.Sheets("Log")
With openWs
start = CDate(InputBox("start (gg/mm/aaaa)"))
end = CDate(InputBox("end (gg/mm/aaaa)"))
Sheets("details").Select
LR = Cells(Rows.Count, "A").End(xlUp).Row
dRow = 2
For r = 2 To LR
If Cells(r, 1) >= start And Cells(r, 1) <= end Then
' Do un nome alle colonne nel file di log indicandone la posizione
ore = Range("K" & r)
nome = Range("J" & r)
totore = totore + ore
If ore <> 8 Then
Range("A" & r & ",J" & r & ",D" & r & ",K" & r).Copy Logore.Cells(dRow, 1)
rigatot = dRow
dRow = dRow + 1
End If
If nome <> Range("J" & r + 1) Then
If totore <> 40 Then
Logore.Cells(dRow, 5) = totore
End If
totore = 0
End If
End If
Next
thiswb.Sheets("Log").Activate
End With
openWb.Close (False)
End Sub
Well, this macro will sum up the values and reprint them as a new list. You can specify the columns as String parameters in your Main sub.
CollectArray "A", "D" - collects array from column A and removes duplicates from it and then prints it to column D
DoSum "D", "E", "A", "B" - summs up all values for column D and writes them to column E - gets the match from column A & values from column B
before:
Option Explicit
Sub Main()
CollectArray "A", "D"
DoSum "D", "E", "A", "B"
End Sub
' collect array from a specific column and print it to a new one without duplicates
' params:
' fromColumn - this is the column you need to remove duplicates from
' toColumn - this will reprint the array without the duplicates
Sub CollectArray(fromColumn As String, toColumn As String)
ReDim arr(0) As String
Dim i As Long
For i = 1 To Range(fromColumn & Rows.Count).End(xlUp).Row
arr(UBound(arr)) = Range(fromColumn & i)
ReDim Preserve arr(UBound(arr) + 1)
Next i
ReDim Preserve arr(UBound(arr) - 1)
RemoveDuplicate arr
Range(toColumn & "1:" & toColumn & Range(toColumn & Rows.Count).End(xlUp).Row).ClearContents
For i = LBound(arr) To UBound(arr)
Range(toColumn & i + 1) = arr(i)
Next i
End Sub
' sums up values from one column against the other column
' params:
' fromColumn - this is the column with string to match against
' toColumn - this is where the SUM will be printed to
' originalColumn - this is the original column including duplicate
' valueColumn - this is the column with the values to sum
Private Sub DoSum(fromColumn As String, toColumn As String, originalColumn As String, valueColumn As String)
Range(toColumn & "1:" & toColumn & Range(toColumn & Rows.Count).End(xlUp).Row).ClearContents
Dim i As Long
For i = 1 To Range(fromColumn & Rows.Count).End(xlUp).Row
Range(toColumn & i) = WorksheetFunction.SumIf(Range(originalColumn & ":" & originalColumn), Range(fromColumn & i), Range(valueColumn & ":" & valueColumn))
Next i
End Sub
Private Sub RemoveDuplicate(ByRef StringArray() As String)
Dim lowBound$, UpBound&, A&, B&, cur&, tempArray() As String
If (Not StringArray) = True Then Exit Sub
lowBound = LBound(StringArray): UpBound = UBound(StringArray)
ReDim tempArray(lowBound To UpBound)
cur = lowBound: tempArray(cur) = StringArray(lowBound)
For A = lowBound + 1 To UpBound
For B = lowBound To cur
If LenB(tempArray(B)) = LenB(StringArray(A)) Then
If InStrB(1, StringArray(A), tempArray(B), vbBinaryCompare) = 1 Then Exit For
End If
Next B
If B > cur Then cur = B
tempArray(cur) = StringArray(A)
Next A
ReDim Preserve tempArray(lowBound To cur): StringArray = tempArray
End Sub
after:
I would like to filter a Listbox created from a list of values stored in a worksheet depending on text written in a textbox contained in the same userform.
My Listbox has 4 or 5 columns (depending on OptionField selection) and I would like to search all the columns for the text written.
Example: I write "aaa" in TextField and the Listbox should return a list based on all the lines whose column 1 or 2 or 3 or 4 or 5 contain "aaa".
Below my code to refresh the list on OptionField selection (this code does not produce any error, it is just to show how I create my list):
Sub RefreshList()
Dim selcell, firstcell As String
Dim k, i As Integer
Dim r as long
i = 0
k = 0
' reads parameters from hidden worksheet
If Me.new_schl = True Then
firstcell = Cells(3, 4).Address
selcell = firstcell
Do Until IsEmpty(Range("" & selcell & "")) And i = 2
If IsEmpty(Range("" & selcell & "")) Then i = i + 1
k = k + 1
selcell = Cells(1 + k, 7).Address(0, 0)
Loop
k = k - 1
selcell = Cells(1 + k, 7).Address(0, 0)
With Me.ListBox1
.ColumnCount = 4
.ColumnWidths = "50; 80; 160; 40"
.RowSource = ""
Set MyData = Range("" & firstcell & ":" & selcell & "")
.List = MyData.Cells.Value
For r = .ListCount - 1 To 0 Step -1
If .List(r, 3) = "" Or .List(r, 3) = "0" Then
.RemoveItem r
End If
Next r
End With
Else
firstcell = Cells(3, 11).Address
selcell = firstcell
Do Until IsEmpty(Range("" & selcell & "")) And i = 11
If IsEmpty(Range("" & selcell & "")) Then i = i + 1
k = k + 1
selcell = Cells(1 + k, 15).Address(0, 0)
Loop
k = k - 1
selcell = Cells(1 + k, 15).Address(0, 0)
With Me.ListBox1
.ColumnCount = 5
.ColumnWidths = "40; 40; 160; 40; 40"
.RowSource = ""
Set MyData = Range("" & firstcell & ":" & selcell & "")
.List = MyData.Cells.Value
For r = .ListCount - 1 To 0 Step -1
If .List(r, 3) = "" Or .List(r, 3) = "0" Then
.RemoveItem r
End If
Next r
End With
End If
End Sub
Finally I could come out with something!
Sub Filter_Change()
Dim i As Long
Dim Str As String
Str = Me.Filter.Text
Me.RefreshList
If Not Str = "" Then
With Me.ListBox1
For i = .ListCount - 1 To 0 Step -1
If InStr(1, LCase(.List(i, 0)), LCase(Str)) = 0 And InStr(1, LCase(.List(i, 1)), LCase(Str)) = 0 And _
InStr(1, LCase(.List(i, 2)), LCase(Str)) = 0 And InStr(1, LCase(.List(i, 3)), LCase(Str)) = 0 Then
.RemoveItem i
End If
Next i
End With
End If
End Sub
I know, the answer is couple of years old...
But I thought I'd share solution that works the best for me, because the filter is blazing fast even when there are thousands of items in the list. It is not without a "catch", though:
it uses a Dictionary object
Option Explicit
Dim myDictionary As Scripting.Dictionary
Private Sub fillListbox()
Dim iii As Integer
Set myDictionary = New Scripting.Dictionary
' this, here, is just a "draft" of a possible loop
' for filling in the dictionary
For iii = 1 To RANGE_END
If Not myDictionary.Exists(UNIQUE_VALUE) Then
myDictionary.Add INDEX, VALUE
End If
Next
myListbox.List = myDictionary .Items
End Sub
Private Sub textboxSearch_Change()
Dim Keys As Variant
Keys = myDictionary .Items
myListbox.List = Filter(Keys, textboxSearch.Text, True, vbTextCompare)
End Sub
Private Sub UserForm_Initialize()
Call fillListbox
End Sub
I'm having problems with the below code in Excel vba. Previously the line rSurname = Range ("A" + numrows).Value was working fine but i've added in the code the check whether the value already exists in the range "D:D" and now I'm getting the Run-time error 13 message
Essentially what I'm trying to do is:
Check that a Surname has only 5 characters
If a surname has less than 5 chars, pad to 5 with spaces
If a surname has more than 5 chars, trim to 5 chars
Add a numeric suffix padded to 4 numbers (ie 0001)
Check that the output doesn't exist already, and if not print to range "D:D"
If value does exist, increment suffix and repeat check until value unique
My code is below
Private Sub TestButton_Click()
Dim rSurname, rOutput, sLength, numrows, sFindString As String
Dim nSuffix As Integer
Dim rRange As Range
Dim iLength As Long
numrows = 1
'Set Cell A2 as first cell range
Range("A2").Select
'Set loop to stop when en empty cell is reached
Do
'Increment numrows
numrows = numrows + 1
'Set Surname value
rSurname = Range("A" + numrows).Value
'Check Surname Letter Count and ensure 5 chars in Surname
iLength = Len(rSurname)
If iLength > 5 Then
rSurname = Left(rSurname, 5)
ElseIf iLength = 4 Then
rSurname = rSurname & " "
ElseIf iLength = 3 Then
rSurname = rSurname & " "
ElseIf iLength = 2 Then
rSurname = rSurname & " "
ElseIf iLength = 1 Then
rSurname = rSurname & " "
Else
rSurname = rSurname
End If
'Set Suffix value
nSuffix = 1
Do
'Combine Surname and suffix
rOutput = rSurname & Format(nSuffix, "0000")
'Check whether Output in list range
sFindString = "rOutput"
If Trim(FindString) <> "" Then
With Sheets("Sheet1").Range("D:D")
Set Rng = .Find(What:=FindString, _
After:=.Cells(.Cells.Count), _
LookIn:=xlValues, _
LookAt:=xlWhole, _
SearchOrder:=xlByRows, _
SearchDirection:=xlNext, _
MatchCase:=False)
If Not Rng Is Nothing Then
rOutput = rOutput
Else
nSuffix = nSuffix + 1
End If
End With
End If
Loop
'Add Outputs to Columns
Range("B" + numrows).Value = rSurname
Range("C" + numrows).Value = nSuffix
Range("D" + numrows).Value = rOutput
Loop Until IsEmpty(rSurname)
End Sub
Here's a much simpler version:
Sub CreateStrings()
Dim rng As Range
Dim i As Long, s As String
Dim cl As Range
Dim v
Set rng = Range([A2], Me.[A2].End(xlDown))
For Each cl In rng.Cells
s = cl.Value
If Len(s) < 5 Then
s = s & Space(5 - Len(s))
Else
s = Left(s, 5)
End If
i = 1
v = Application.Match(s & Format(i, "0000"), Me.[D:D], 0)
Do While Not IsError(v)
i = i + 1
v = Application.Match(s & Format(i, "0000"), Me.[D:D], 0)
Loop
cl.Offset(, 3) = s & Format(i, "0000")
Next
End Sub
probably better to get rit off the filter and use a worksheet function like
iFoundStrings =
Application.WorksheetFunction.CountIf(Sheets("Sheet1").Range("D:D"),
FindString)