I have string each on multiple line which looks like this
S087A1097,99,86,0,14,0,good
S087A1097,100,0,10,14,0,good
S087A1097,0,0,100,0,0,good
And I need to change it to this respectively.
S087A1097,99.86,0.14,0,good
S087A1097,100.0,10.14,0,good
S087A1097,0.0,100.0,0,good
How can I achieve this in Excel
if your text is in cell A1:
=SUBSTITUTE(SUBSTITUTE(A1,",",".",2),",",".",3)
If you want to use a VBA solution, you can try the code below.
It might seem a little long, but it's very fast to execute since there is little "messing" with the worksheet, and most of the logic is done on Arrays.
Code
Option Explicit
Sub ImportCsvContents()
Dim csvLines As Variant, CurrentRow As Variant
Dim LastRow As Long, i As Long
ReDim csvLines(0)
With Worksheets(1)
LastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
' === logic, each order ends with data data in column "B" ===
For i = 1 To LastRow
csvLines(UBound(csvLines)) = .Range("A" & i).Value
ReDim Preserve csvLines(UBound(csvLines) + 1) ' keep record and raise array index by 1
Next i
End With
' resize array to actual populated size
If csvLines(UBound(csvLines)) = "" Then
ReDim Preserve csvLines((UBound(csvLines) - 1))
End If
' loop through all lines in .csv file
For i = 0 To UBound(csvLines)
CurrentRow = Split(csvLines(i), ",")
CurrentRow(1) = CurrentRow(1) & "." & CurrentRow(2)
CurrentRow(2) = CurrentRow(3) & "." & CurrentRow(4)
CurrentRow(3) = CurrentRow(5)
CurrentRow(4) = CurrentRow(6)
' re-format the current line
csvLines(i) = CurrentRow(0) & "," & CurrentRow(1) & "," & CurrentRow(2) & "," & CurrentRow(3) & "," & CurrentRow(4)
Erase CurrentRow ' clear array
Next i
' now just dump the entre array to the worksheet
Worksheets(1).Range("A1").Resize(UBound(csvLines) + 1).Value = Application.Transpose(csvLines)
End Sub
Related
I have been trying to Concatenate two Columns directly from the Table1. But i really do not know how. I have tried and make below code.
But I have been creating first 2 helping Column in in "DI" and "DJ" to make this thing work.
I do not want to use these two helping columns directly wants the concatenate result in "DK2"
All help will be appreciaed.
Dim O As String
Dim P As String
O = "Milestone"
P = "Task"
Sheet1.Range("Table1[" & O & "]").Copy
Sheet2.Range("DI2").PasteSpecial xlPasteValues
Sheet1.Range("Table1[" & P & "]").Copy
Sheet2.Range("DJ2").PasteSpecial xlPasteValues
For i = 2 To Cells(Rows.Count, "DH").End(xlUp).Row
Sheet2.Cells(i, "DK").Value = Sheet2.Cells(i, "DI").Value & "" & Sheet2.Cells(i, "DJ").Value
Next i
Here is the example Picture
Try this.
Range("DK2").Resize(Sheet2.ListObjects("Table1").ListRows.Count) = Application.Evaluate("Table1[Milestone]&Table1[Task]")
EDIT: I've seen #norie's answer and it is simpler and more efficient than mine. I'll keep my answer here for anyone who is curious, but I recommend using his solution.
The trick is to use =INDEX(YOUR_TABLE[YOUR_COLUMN]], YOUR_ROW_STARTING_FROM_1) in order to obtain the cell contents that you needed.
Here you are your code edited:
Original
Dim O As String
Dim P As String
Dim i As Integer
O = "Milestone"
P = "Task"
For i = 1 To Application.Evaluate("ROWS(Table1[" & O & "])")
Sheet2.Cells(i, "DK").Value = Application.Evaluate("INDEX(Table1[" & O & "], " & i & ") & INDEX(Table1[" & P & "], " & i & ")")
Next i
Optimized
Dim O As String
Dim P As String
Dim i As Integer
O = "Milestone"
P = "Task"
' Disable formula recalculation while trying to add our data to increase performance
Application.Calculation = xlManual
' Disable screen updating while trying to add our data to improve performance
Application.ScreenUpdating = False
For i = 1 To Application.Evaluate("ROWS(Table1[" & O & "])")
Sheet2.Cells(i, "DK").Value = Application.Evaluate("INDEX(Table1[" & O & "], " & i & ") & INDEX(Table1[" & P & "], " & i & ")")
Next i
' Enable again formula's automatic evaluation.
Application.Calculation = xlAutomatic
' Enable again screen updating
Application.ScreenUpdating = True
Optimized using only Formulas (this performs better that the others)
Dim O As String
Dim P As String
Dim i As Integer
O = "Milestone"
P = "Task"
' Disable formula recalculation while trying to add our data to increase performance
Application.Calculation = xlManual
' Disable screen updating while trying to add our data to improve performance
Application.ScreenUpdating = False
For i = 1 To Application.Evaluate("ROWS(Table1[" & O & "])")
Sheet2.Cells(i, "DK").FormulaR1C1 = "=INDEX(Table1[" & O & "], " & i & ") & INDEX(Table1[" & P & "], " & i & ")"
Next i
' Enable again formula's automatic evaluation.
Application.Calculation = xlAutomatic
' Enable again screen updating
Application.ScreenUpdating = True
Optimized using Formulas and then converting back to values
Dim O As String
Dim P As String
Dim i As Integer
O = "Milestone"
P = "Task"
' Disable formula recalculation while trying to add our data to increase performance
Application.Calculation = xlManual
' Disable screen updating while trying to add our data to improve performance
Application.ScreenUpdating = False
For i = 1 To Application.Evaluate("ROWS(Table1[" & O & "])")
Sheet2.Cells(i, "DK").FormulaR1C1 = "=INDEX(Table1[" & O & "], " & i & ") & INDEX(Table1[" & P & "], " & i & ")"
Next i
' Enable again formula's automatic evaluation.
Application.Calculation = xlAutomatic
' Enable again screen updating
Application.ScreenUpdating = True
' Convert from formulas to values
Range("DK:DK").Copy
Range("DK:DK").PasteSpecial xlPasteValues
This can be done directly in the worksheet by using the Index function
Reference first cell in the table: =INDEX(Table1,1,1)
Concatenate cell 1 and 2 values: =INDEX(Table1,1,1)&INDEX(Table1,1,2)
It gets slightly more complicated if you want to be able to copy formulae across or down as you need to reference the current cell location
Reference first cell in the table using offsets: =INDEX(Table1,ROW()-X,COLUMN()-Y) where X, Y (minus data location offsets) are the numerical row/column of the cell where you have placed the formula.
i.e. if placing the formula in E2 to reference Table1 cell(1,1) => =INDEX(Table1,ROW()-1,COLUMN()-4)
where Column E=> Offset 4, Row 2 => Offset 1
or: =INDEX(Table1,ROW()-ROW($E$2)+1,COLUMN()-COLUMN($E$2)+1)
You can now autofill the formula down or across
Concatenate List Columns
With your amount of data both solutions may seem equally efficient. I've tested it with a million rows of random numbers from 1 to 1000, and the first solution took about 3.5 seconds, while the second took about 5.5 seconds on my machine. The first solution is just a more elaborate version of norie's answer.
In this solution, you can add more columns (headers) and use a delimiter. While adding more columns the difference in the efficiencies will become more apparent, while when adding more characters to the delimiter, the efficiencies will decrease seemingly equally.
The Code
Option Explicit
Sub concatListColumnsEvaluate()
Dim dTime As Double: dTime = Timer
' Define constants.
Const TableName As String = "Table1"
Const HeadersList As String = "Milestone,Task"
Const dFirst As String = "D2"
Const Delimiter As String = ""
' Determine table rows count.
Dim rCount As Long: rCount = Sheet1.ListObjects(TableName).ListRows.Count
' Create Evaluate Expression String.
Dim Headers() As String: Headers = Split(HeadersList, ",")
Dim tUpper As Long: tUpper = UBound(Headers)
Dim evString As String
Dim t As Long
If Len(Delimiter) = 0 Then
For t = 0 To tUpper
evString = evString & TableName & "[" & Headers(t) & "]" & "&"
Next t
evString = Left(evString, Len(evString) - 1)
Else
For t = 0 To tUpper
evString = evString & TableName & "[" & Headers(t) & "]" & "&""" _
& Delimiter & """&"
Next t
evString = Left(evString, Len(evString) - Len(Delimiter) - 4)
End If
' Write values to Destination Range.
Sheet2.Range(dFirst).Resize(rCount).Value = Application.Evaluate(evString)
Debug.Print Timer - dTime
End Sub
Sub concatListColumnsArrays()
Dim dTime As Double: dTime = Timer
' Define constants.
Const TableName As String = "Table1"
Const HeadersList As String = "Milestone,Task"
Const dFirst As String = "D2"
Const Delimiter As String = ""
' Write values from list columns to arrays of Data Array.
Dim Headers() As String: Headers = Split(HeadersList, ",")
Dim tUpper As Long: tUpper = UBound(Headers)
Dim Data As Variant: ReDim Data(0 To tUpper)
Dim t As Long
For t = 0 To tUpper
' Either...
Data(t) = Sheet1.Range(TableName & "[" & Headers(t) & "]").Value
' ... or:
'Data(t) = Sheet1.ListObjects(TableName) _
.ListColumns(Headers(t)).DataBodyRange.Value
Next t
' Concatenate values of arrays of Data Array in Result Array.
Dim rCount As Long: rCount = UBound(Data(0), 1)
Dim Result As Variant: ReDim Result(1 To rCount, 1 To 1)
Dim r As Long
If Len(Delimiter) = 0 Then
For r = 1 To rCount
For t = 0 To tUpper
Result(r, 1) = Result(r, 1) & Data(t)(r, 1)
Next t
Next r
Else
For r = 1 To rCount
For t = 0 To tUpper
Result(r, 1) = Result(r, 1) & Data(t)(r, 1) & Delimiter
Next t
Result(r, 1) = Left(Result(r, 1), Len(Result(r, 1)) _
- Len(Delimiter))
Next r
End If
' Write values from Result Array to Destination Range.
Sheet2.Range(dFirst).Resize(rCount).Value = Result
Debug.Print Timer - dTime
End Sub
I'm making a VBA macro to concatenate a number given by the user with a previous column value. Once the loop gets to the value given by the user (the top value), the loop would start again since number one. By now my loop gets to the top value and starts from one, but every time this happened the code skip to the next cell, could you tell me why is this happening guys? (down value by default).
Sorry i'm a little bit new on VBA, here is my try:
Sub Balance()
Dim myValue As Integer
myValue = InputBox("Please, give me a number")
Range("A2").Select
Range("A:A,C:C,F:F,H:J,L:L,T:T,W:X").Delete
Range("A2").Select
firstrow = ActiveCell.Row
Selection.End(xlDown).Select
lastrow = ActiveCell.Row
For i = 1 To lastrow
If Range("M" & i) = "AB" Then
For j = 1 To myValue
watcher = j
Range("N" & i) = "TV" & " " & Range("M" & i) & " " & watcher
i = i + 1
Next j
End If
Next i
End Sub
This the output with the number 10 as input (Column N):
I would like to reach this goal:
You already have your answer by Vandear explaining why the row is getting skipped. However here is an alternative way using only one loop to achieve what you want. But before that couple of suggestions
Suggestions:
Use Option Explicit and declare your variables. You may want to see Optimizing the VBA Code and improve the performance
Avoid the use of Select/Activate You may want to see How to avoid using Select in Excel VBA
Avoid the use of xlDown to get the last row. You may want to see Finding Last Row
When accepting number from users, use Application.InputBox with a Type:=1 instead of just InputBox. This way you will only restrict numbers.
Is this what you are trying?
Code:
Option Explicit
Sub Balance()
Dim ws As Worksheet
Dim lRow As Long
Dim i As Long, counter As Long
Dim myValue As Long
myValue = Application.InputBox(Prompt:="Please, give me a number", Type:=1)
If myValue < 1 Then Exit Sub
'~~> Change this to the relevant sheet
Set ws = Sheet1
With ws
'~~> For demonstration below. I did not use this line below. But
'~~> If you need to delete those columns then use it this way
.Range("A:A,C:C,F:F,H:J,L:L,T:T,W:X").Delete
lRow = .Range("A" & .Rows.Count).End(xlUp).Row
'~~> Set your counter
counter = 1
For i = 1 To lRow
If .Range("M" & i) = "AB" Then
Range("N" & i) = "TV" & " " & .Range("M" & i).Value2 & " " & counter
counter = counter + 1
'~~> Reset your counter if it crosses user input
If counter > myValue Then counter = 1
End If
Next i
End With
End Sub
In action:
Couple of things before I answer your problem:
It's advisable to declare your variables for better structure:
Dim i As Integer, j As Integer, MyValue As Integer, firstrow As Integer, lastrow As Integer
You can skip the selection of a cell and directly reference it:
firstrow = Range("A2").Row
lastrow = Range("A2").End(xlDown).Row
The Answer to your Problem:
When the code exits the for-next loop for j, i is increased by 1 (i=i+1), and then it will be increased again by 1 when it proceeds to the next i line. This is the reason why it skips to the next row. So after the for-next loop for j, you need to decrease i by 1 before proceeding to the for-next loop for i.
For i = 1 To lastrow
If Range("M" & i) = "AB" Then
For j = 1 To myValue
watcher = j
Range("N" & i) = "TV" & " " & Range("M" & i) & " " & watcher
i = i + 1
Next j
i=i-1 <-------
End If
Next i
(eg: 1=(x1,y1), 3=(x1,y1,x2,y2,x3,y3)
How do i remove the unnecessary "(,)" as shown below and put the number of position of the x,y coordinates of the reliability fail with reference to the number under the header of reliability fails?
Eg: Reliability fail counts =2 in device WLR8~LW~VBD~MNW should give me the position of that fail counts at the same row as the device at columnX. Anyways please ignore the data under the V and W column in my pictures.
Current output based on my code
What i really want
Current issue
Current issue2
where it should be
Dim output As Variant
Dim outputrow As Integer
output = ""
outputrow = 0
Dim ws1 As Worksheet
Set ws1 = ThisWorkbook.Sheets(1)
Dim ia As Long
Dim lastrow2 As Long
lastrow2 = ws1.Range("U2:U" & ws1.Rows.Count).Find(What:="*", SearchDirection:=xlPrevious, SearchOrder:=xlByRows).Row
If ws1.Range("U1") = "Reliability Fail" Then
For ia = 2 To lastrow2
If ws1.Cells(ia, "U").Value = 0 Then
output = output & "(" & ws1.Cells(ia, "Y").Value & "," & ws1.Cells(ia, "Z").Value & "),"
ElseIf output = "(,)," Then 'if there are no x and y values in Y and Z column stop showing "(,),"
output = ""
End If
If ws1.Cells(ia, "U").Value > 0 Then
ws1.Cells(ia, "U").Offset(0, 3).Value = Left(output, Len(output) - 1) 'extract the x and y values obtain in (x,y) format
'if there is "value" under reliability fails(column U), put the x y position at the same row as the "value" at column X
End If
Next
End If
I suggest using an inner loop so that extra brackets don't get added in the first place
Option Explicit
Sub test()
Dim output As Variant
Dim outputrow As Integer
Dim valueCount As Long, ib As Long
output = ""
outputrow = 0
Dim ws1 As Worksheet
Set ws1 = ThisWorkbook.Sheets(1)
Dim ia As Long
Dim lastrow2 As Long
lastrow2 = ws1.Range("U2:U" & ws1.Rows.Count).Find(What:="*", SearchDirection:=xlPrevious, SearchOrder:=xlByRows).Row
If ws1.Range("U1") = "Reliability Fail" Then
' Outer loop over all rows
For ia = 2 To lastrow2
valueCount = ws1.Cells(ia, "U").Value
output = ""
' Inner loop to process repeated rows
For ib = 1 To valueCount
output = output & "(" & ws1.Cells(ia + ib - 1, "Y").Value & "," & ws1.Cells(ia + ib - 1, "Z").Value & ")"
If ib < valueCount Then output = output & ","
Next ib
ws1.Cells(ia, "U").Offset(0, 3).Value = output
Next ia
End If
End Sub
EDIT
Here is the amended code in light of OP's later example:
Option Explicit
Sub test()
Dim output As Variant
Dim outputrow As Integer
Dim valueCount As Long, ib As Long, rowPointer As Long
output = ""
outputrow = 0
Dim ws1 As Worksheet
Set ws1 = ThisWorkbook.Sheets(1)
Dim ia As Long
Dim lastrow2 As Long
lastrow2 = ws1.Range("U2:U" & ws1.Rows.Count).Find(What:="*", SearchDirection:=xlPrevious, SearchOrder:=xlByRows).Row
If ws1.Range("U1") = "Reliability Fail" Then
rowPointer = 2
' Outer loop over all rows
For ia = 2 To lastrow2
valueCount = ws1.Cells(ia, "U").Value
output = ""
' Inner loop to process repeated rows
For ib = 1 To valueCount
output = output & "(" & ws1.Cells(rowPointer, "Y").Value & "," & ws1.Cells(rowPointer, "Z").Value & ")"
If ib < valueCount Then output = output & ","
rowPointer = rowPointer + 1
Next ib
ws1.Cells(ia, "U").Offset(0, 3).Value = output
Next ia
End If
End Sub
First, strip out the extra blank pairs using this:
output = Replace(Range("X" & lRow), ",(,)", "")
You should then have it down to just the pairs you want.
Then split it based on ), and append a ) if it doesnt end in one. Here is an example you can use to incorporate it in your code:
Sub test()
Dim lRow As Long
Dim vSplit As Variant
Dim sResult As String
Dim output as String
For lRow = 2 To 3
If Len(Range("X" & lRow)) > 0 And Val(0 & Range("U" & lRow)) > 0 Then
output = Replace(Range("X" & lRow), ",(,)", "") ' this strips out the extra empty pairs
vSplit = Split(output, "),") ' this creates a string array, 1 item for each pair
sResult = vSplit(Val(Range("U" & lRow)) - 1) ' this gets the one you want based on column U ( -1 because the Split array is 0 based)
If Right$(sResult, 1) <> ")" Then sResult = sResult & ")" ' this adds a ")" if one is missing
Debug.Print sResult ' debug code
Range("X" & lRow) = sResult ' this adds the result to column X, replacing what was there
End If
Next
End Sub
Currently I am trying to improve the performance of my VBA program, because it takes forever to perform some table operations.
During the programs runtime I am trying to store data in worksheets, but the write-operations take for ever and I would like to store this data dynamically instead of writing it into a worksheet to reduce the time it needs to run.
I was thinking about using arrays instead of the worksheets to store the data but I am not quite sure whether this will work because I do not know how many rows/columns my table exactly has.
Here my code, any help is appreciated!
Public row As Long
Public rowMax As Long
Public startRow As Integer
Public materialType As String
Public filter As String
Public col As Integer
Public colMax As Integer
Public isUsed As Boolean
Public a As Integer
Sub bestimmeObFelderGenutzt()
Debug.Print ("bestimmeObFelderGenutzt:begin" & " " & Now())
With Sheets("Sheet1")
filter = "I"
startRow = 2
rowMax = Sheets("Sheet1").Cells(.Rows.Count, "F").End(xlUp).row
colMax = Sheets("Sheet1").Cells(1, .Columns.Count).End(xlToLeft).Column
materialType = Sheets("Sheet1").Range(filter & startRow).Value
Dim ws As Worksheet
Set ws = ThisWorkbook.Sheets.Add(After:= _
ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count))
ws.Name = "Nutzung"
For col = 1 To colMax
Sheets("Nutzung").Cells(1, col + 2).Value = Sheets("Sheet1").Cells(1, col).Value
Next col
For row = 2 To rowMax
Sheets("Nutzung").Range("A" & row).Value = Sheets("Sheet1").Range("A" & row).Value
Sheets("Nutzung").Range("B" & row).Value = Sheets("Sheet1").Range("I" & row).Value
For col = 1 To colMax
If IsEmpty(Sheets("Sheet1").Cells(row, col)) = False Then
isUsed = True
Sheets("Nutzung").Cells(row, col + 2).Value = 1
Else:
Sheets("Nutzung").Cells(row, col + 2).Value = 0
End If
Next col
Next row
End With
Debug.Print ("bestimmeObFelderGenutzt:end" & " " & Now())
End Sub
Sub findeUngenutzteSpalten(ByVal materialType As String, pos As Integer)
Debug.Print ("findeUngenutzteSpalten:begin" & " " & materialType & " " & Now())
With Sheets(materialType)
rowMax = Sheets(materialType).Cells(.Rows.Count, "F").End(xlUp).row
colMax = Sheets(materialType).Cells(1, .Columns.Count).End(xlToLeft).Column
Sheets("Auswertung").Cells(1, 1).Value = "Spaltenüberschrift:"
Dim a As Integer
For a = 1 To colMax
Sheets("Auswertung").Cells(a + 1, 1).Value = Sheets("Sheet1").Cells(1, a).Value
Next a
Sheets("Auswertung").Cells(1, pos + 1).Value = materialType
For col = 3 To colMax
For row = 2 To rowMax
If Sheets(materialType).Cells(row, col).Value = 1 Then
Sheets("Auswertung").Cells(col - 1, pos + 1).Value = "Ja"
GoTo WeiterCol
Else:
If row = rowMax Then
Sheets("Auswertung").Cells(col - 1, pos + 1).Value = "Nein"
Else:
GoTo WeiterRow
End If
End If
WeiterRow:
Next row
WeiterCol:
Next col
End With
Debug.Print ("findeUngenutzteSpalten:end" & " " & materialType & " " & Now())
End Sub
Sub kopiereZeilen(ByVal materialType As String)
Debug.Print ("kopiereZeilen:begin" & " " & materialType & " " & Now())
With Sheets("Nutzung")
rowMax = Sheets("Nutzung").Cells(.Rows.Count, "F").End(xlUp).row
Dim ws As Worksheet
Set ws = ThisWorkbook.Sheets.Add(After:= _
ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count))
ws.Name = materialType
Sheets("Nutzung").Cells(1, 1).EntireRow.Copy Sheets(materialType).Cells(1, 1)
Dim unusedRow As Long
For row = 2 To rowMax
unusedRow = Sheets(materialType).Cells.SpecialCells(xlCellTypeLastCell).Offset(1, 0).row
If Sheets("Nutzung").Cells(row, 2).Value = materialType Then
Sheets("Nutzung").Cells(row, 2).EntireRow.Copy Sheets(materialType).Cells(unusedRow, 1)
End If
Next row
End With
Debug.Print ("kopiereZeilen:end" & " " & materialType & " " & Now())
End Sub
Sub allesZusammen()
Debug.Print ("Hauptaufruf:begin" & " " & Now())
Dim types(10) As String
Dim element As Variant
Dim pos As Integer
bestimmeObFelderGenutzt
types(0) = "A"
types(1) = "B"
types(2) = "C"
types(3) = "D"
types(4) = "E"
types(5) = "F"
types(6) = "G"
types(7) = "H"
types(8) = "I"
types(9) = "J"
types(10) = "K"
Dim ws As Worksheet
Set ws = ThisWorkbook.Sheets.Add(After:= _
ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count))
ws.Name = "Auswertung"
For Each element In types
kopiereZeilen (element)
pos = Application.Match(element, types, False)
findeUngenutzteSpalten element, pos
Next element
Debug.Print ("Hauptaufruf:end" & " " & Now())
End Sub
You can declare dynamic arrays. The general syntax is:
Dim Values() As Long
To use the array, you must first re-dimension it to the size you want. For example this declares a two-dimensional array of 3 x 5 values (zero based):
ReDim Values(2, 4)
If you want to size based on variables then use something like:
ReDim Values(myrowsize, mycolumnsize)
You can grow (or shrink) the array dynamically by using this syntax:
ReDim Preserve Values(2, mynewsize)
Note, that you can only re-dimension the last index of the array. So this is not allowed:
ReDim Preserve Values(mynewsize, 4)
But this is probably ok in your case, as you have a fixed number of columns.
It is perfectly ok to declare the dynamic array as a UDT. For example:
Type UDTInfo
valueA As Long
valueB As Long
End Type
Sub test()
Dim Values() As UDTInfo
ReDim Values(2, 4)
ReDim Preserve Values(2, 5)
End Sub
You can access the array in the normal way:
x = Values(1, 2)
You can copy one dynamic array to another directly, as long as the types and number of dimensions match (size doesn't matter):
Dim Values() As Integer
Dim Results() As Integer
Results = Values
And lastly, you can pass dynamic arrays to and from functions in the following way:
Function SomeFunc(ByRef Values() As Long) As Long()
Dim ReturnValues() As Long
ReturnValues = Values
SomeFunc = ReturnValues
End Function
Note, you only pass dynamic arrays ByRef but not ByVal.
Hello I am looking for help, I have one textbox and one listbox in an Excel Userform, it works flawlessly except for one small Detail: as soon as the results appear in the listbox they represent the search within all columns. The first column, however is hidden when I type in the textbox, how can I make sure the column remains visible during search?
Thanks in advance
Here is the code:
Private Sub UserForm_Initialize()
End Sub
Private Sub TextBox1_Change()
With Sheets("Sheet1")
lr = .Range("A" & Rows.Count).End(xlUp).Row
ReDim arr(1 To lr - 1)
ReDim sn(1 To lr - 1, 1 To 13)
For i = 1 To UBound(arr)
arr(i) = .Range("A" & i + 2) & " " & .Range("B" & i + 2) & " " & .Range("C" & i + 2) & " " & .Range("D" & i + 2) & " " & .Range("E" & i + 2) & " " & .Range("F" & i + 2)
If InStr(1, arr(i), TextBox1) > 0 Then
j = j + 1
For X = 2 To 8
sn(j, X - 1) = .Cells(i + 2, X)
Next
End If
Next
ListBox1.List = sn
End With
End Sub
Consistent Array Approach
Your original code shows a mixture of array and range loops when creating a filtered listbox list. In order to be more consistent here by looping through arrays only *) , you could refine your code as follows (e.g. using the same match check via Instr):
Userform Event procedure TextBox1_Change()
Private Sub TextBox1_Change()
Const STARTROW = 3
Dim i&, iCnt&, r&, c& ' array counters for "rows" and "columns"
Dim sn, tmp ' variant 2-dim 1-based arrays
With Sheets("Sheet1")
iCnt = .Range("A" & Rows.Count).End(xlUp).Row - STARTROW + 1 ' items counter
ReDim sn(1 To iCnt, 1 To 13) ' provide for filtered data array
For i = 1 To iCnt
'assign current data row to 2-dim 1-based temporary array
tmp = .Range("A" & (i + 2) & ":F" & (i + 2)) ' current data row (c.f. OP)
'compare search string with concatenated data string from current row
If InStr(1, concat(tmp), TextBox1.Text) > 0 Then ' check occurrence e.g. via Instr
r = r + 1 ' new rows counter
For c = 1 To UBound(tmp, 2) ' col counter
sn(r, c) = tmp(1, c) ' collect found row data
Next
End If
Next
ListBox1.List = sn ' assign array to .List property
End With
End Sub
Helper function concat() called by above event procedure
Private Function concat(ByVal arr, Optional ByVal delim$ = " ") As String
' Purpose: build string from 2-dim array row, delimited by 2nd argument
' Note: concatenation via JOIN needs a "flat" 1-dim array via double transposition
concat = Join(Application.Transpose(Application.Transpose(arr)), delim)
End Function
Notes
*) Looping through a range by VBA is always time consuming, so do this with arrays instead.
You might be also interested in the following solution demonstrating the use of the listbox Column property. By playing around this could help you to remove the superfluous blank rows in the listbox.