I need to generate an array for a 'write line' custom function. This function writes a single row of cells (the array) to a text file during a loop.
This array is static in size.
The row to be written to the text file is 'detected' by the Rng variable below:
Set Rng = Worksheets("Sheet1").Columns(5).Find(userform1.ComboBox1.Value)
i.e. the Rng variable only indexes a single cell in column 5 - as matched by the value in ComboBox1. The array to be written by writeLine will be column 6:49 of the row matched by Rng.
The arguments for the 'write line' function are
the value of the combobox i.e. userform1.combobox1.value, and
the array to be written in the 'write line' function
So far, I have this:
Private Sub CommandButton18_Click()
Dim Range As Range
Dim Array As Range
Set Range = Worksheets("Sheet1").Columns(5).Find(userform1.ComboBox1.Value) ''anticipated to set the row index of the array???
Array = ????
Function.writeLine(userform1.ComboBox1.Value,????)
End Sub
The trouble I am having is to create an array that incorporates the changing row whilst having the number of columns fixed?
Here is part of the writeLine function:
Do Until objTF.AtEndOfStream
readString = objTF.readline
data = Split(readString, vbTab)
foundID = data(0)
If StrComp(**foundID, ID**, 1) <> 0 Then
objTF2.writeLine (readString)
ElseIf StrComp(**foundID, ID**, 1) = 0 Then
'write initial value outside the loop
strTmp = Split(readString, strDelim)
'Modify the data array to include the data provided by writeArray
For argPos = 5 To UBound(data)
'check for index out of bounds, stop writing if it is!
If (argPos - 5) > UBound(writeArray) Then Exit For 'need to check this will exit if the value is index out of bounds.
data(argPos) = writeArray(dataPos)
dataPos = dataPos + 1
Next argPos
'Take each entry from data and build a string delimited by strDelim
Do Until counter > UBound(data)
resultStr = IIf(counter <= UBound(data), resultStr & data(counter) & strDelim, resultStr & data(counter))
counter = counter + 1
Loop
'output to temp file
objTF2.writeLine (resultStr)...
Basically, the "foundID" and "ID" are the variables to be matched in order to write the array to the text file. The "ID" is the ComboBox1.value. "foundID" is the value in column 5 of the spreadsheet. Column 6:49 (the array) are to be written to the text file.
Use Ubound to get the range as array.
Private Sub CommandButton18_Click()
Dim rRange As Range
Dim colno As Long
Dim rownumber As Long
Dim sString As String
lastrow = 10
For colno = 6 To 43
For rownumber = 1 To lastrow
sString = Worksheets("sheet1").Cells(rownumber, colno)
Next rownumber
Next
End Sub
Related
I have this text file that is tab separated with about 1,000 columns and 12,000 rows when pasted into an excel spreadsheet. My goal is to have some way where I can compare an array of strings
arWords = Array("Title1", "Title2", "Title3")
To the column headers in that .txt file. When a match is found i would like to know what "column" that word was found in, and put it in another array. In this example it would be an array of 3 integers each one representing which column each Title was found. My goal is to end up with an array that looks like this.
listIndex = array(159, 393, 400)
And if i include 4 Titles in arWords, then i will end up with an array of 4 integers representing their column #.
Here is my code, its not good im very bad at this, but thanks nonetheless!
Const ForReading = 1
Dim FSO, FileIn, strTmp
Set FSO = CreateObject("Scripting.FileSystemObject")
Set FileIn = FSO.OpenTextFile(movietitles.txt, ForReading)
arWords = Array("Title1", "Title2", "Title3")
size = UBound(arWords) - LBound(arWords) + 1
Dim listIndex() As Integer
ReDim listIndex(size)
Do Until FileIn.AtEndOfStream
strTmp = FileIn.ReadLine
If Len(strTmp) > 0 Then
For i = 0 To UBound(arWords)
If InStr(1, strTmp, arWords(i), vbTextCompare) > 0 Then
listIndex(i) = i
Exit For
End If
Next
End If
Loop
FileIn.Close
ReDim yArray(1 To lColumn)
Dim Counter As Integer
For Counter = 1 To lColumn
yArray(Counter) = 9
Next Counter
For Each Index In listIndex
yArray(Index) = 1
Next Index
If my assumption after reading your comment is correct, please try the next code. I assumed that the header is on the first row of the text file. No need to open it in Excel:
Sub MatchStringArrayToHeaders()
Dim fileName As String, arWords, arrTxt, arrH, arrFin, El, mtch
Dim k As Long, headRow As Long i As Long
fileName = ThisWorkbook.path & "\MyTestFile.txt" 'use here your text file full name
arWords = Array("Title1", "Title2", "Title3")
ReDim arrFin(UBound(arWords)) 'redim the final array to be returned
'put all the text file content in an array of rows:
arrTxt = Split(CreateObject("Scripting.FileSystemObject").OpenTextFile(fileName, 1).ReadAll, vbCrLf)
'find the header row: __________________________
For i = 0 To UBound(arrTxt)
arrH = Split(arrTxt(i), vbTab)
If UBound(arrH) > 0 Then
If arrH(1) <> "" Then HeaderRow = i: Exit For
End If
Next i
'_______________________________________________
arrH = Split(arrTxt(headRow), vbTab)
For Each El In arWords
mtch = Application.match(El, arrH, 0) 'return the matching header number
If IsNumeric(mtch) Then 'if a match could be found
arrFin(k) = mtch: k = k + 1 'put the column number in the final array
Else
'if not any match, write in Immediate Window the not matching string
Debug.Print El & " could not be found in the headers row..."
End If
Next
'Only to visually check the returned array:
Debug.Print Join(arrFin, "|") 'the obtained array is joined using "|" separator and returned in Immediate Window (`Ctrl + G`, being in VBE).
End Sub
If the headers row is not all the time the same, please give me the column 1 marker for this header row and I will adapt the code to firstly search for this marker, set the headers row and use it...
I am trying to write a process that compares strings and deletes the duplicate string within a given column using a selection as the top and bottom constraints.
Most of the process of checking and deleting works however I am having trouble with moving the cell contents up a cell after the duplicate string was deleted.
Image showing how the script should work
Red outline is the loop that selects the String to compare against.
Green outline is the loop that finds, deletes and moves the cells up one.
Blue outline is the Selection.
Stage 1 is to find and compare two strings that are the same.
Stage 2 is to delete the string that is the same as the first string.
Stage 3 is to move everything under the deleted cell with the deleted string up one row so that there is no empty cell.
I'm having problems with stage 3. I don't know how to move all data in those cells up one row without using a loop and I can't use the selection.
Here is the code so far:
Private Sub Tabeller()
Dim vRngMv As Variant
Dim iRowChsr1, iRowChsr2, iRowTtl, iI As Integer
Dim vRowIn, vRowComp As String
Dim oRngSlct, oRngMv As Range: Dim ws As Worksheet: Dim oBS As Object
'Newer Version will get rid of Selection as range determination
'Why does oRngSlct become a Variant/Object/Range here and oRngMv stays a Range object?
'I dont use it, kept it in to ask the question.
Set oRngMv = Selection: Set oRngSlct = Selection
iRowTtl = oRngSlct.Rows.Count
'First Loop For holding target cell data for comparison
For iRowChsr1 = 1 To iRowTtl
'Chooses target cell and string
vRowIn = oRngSlct(iRowChsr1, 1)
'Second loop for Seeking a matching String
For iRowChsr2 = 1 To iRowTtl
'Check to not pick itself
If iRowChsr1 = iRowChsr2 Then
'Offsets Counter by 1 if it enocunters itself
iRowChsr2 = iRowChsr2 + 1
Else
'Sets comparison string
vRowComp = oRngSlct(iRowChsr2, 1)
'String comparison
iI = StrComp(vRowIn, vRowComp, 1)
'If strings are equal
If iI = 0 Then
'Deletes; I know this is redundant but its here for clarity
oRngSlct(iRowChsr2, 1) = ""
'Offsets by iRowChsr by 1
iRowChsr2 = iRowChsr2 + 1
'Create Variant with proper range, it just has to be translated into something that excel can move.
vRngMv = Range((oRngSlct(iRowChsr2, 1)), (oRngSlct(iRowTtl, 1)))
Set oRngMv = Range 'I know this doesnt work
'Offsets back to original Position of Deleted cell
iRowChsr2 = iRowChsr2 - 1
'*******************************
'*Cuts and pastes or moves here*
'*******************************
End If
End If
'Next Comparison String
Next iRowChsr2
'Next target String
Next iRowChsr1
End Sub
Unique (Remove Duplicates)
You could rather use one of the following.
The first solution will leave error values and blanks as part of the resulting data, while the second one will remove them.
The Code
Option Explicit
Sub removeDupesColumnSelection()
' Validate Selection.
If TypeName(Selection) <> "Range" Then Exit Sub
' Remove duplicates.
Selection.Columns(1).RemoveDuplicates Array(1), xlNo
End Sub
Sub uniquifyColumnSelection()
' Validate Selection.
If TypeName(Selection) <> "Range" Then Exit Sub
' Write values from first column of Selection to Data Array.
Dim rg As Range: Set rg = Selection.Columns(1)
Dim rCount As Long: rCount = rg.Rows.Count
Dim Data As Variant
If rCount > 1 Then
Data = rg.Value
Else
ReDim Data(1 To 1, 1 To 1): Data(1, 1) = rg.Value
End If
' In Unique Dictionary...
With CreateObject("Scripting.Dictionary")
.CompareMode = vbTextCompare
' Write unique values from Data Array to Unique Dictionary.
Dim Key As Variant
Dim i As Long
For i = 1 To rCount
Key = Data(i, 1)
If Not IsError(Key) Then
If Len(Key) > 0 Then
.Item(Key) = Empty
End If
End If
Next i
ReDim Data(1 To rCount, 1 To 1)
If .Count > 1 Then
' Write values from Unique Dictionary to Data Array.
i = 0
For Each Key In .Keys
i = i + 1
Data(i, 1) = Key
Next Key
End If
End With
' Write values from Data Array to Destination Range.
rg.Value = Data
End Sub
For any 2-column array A, set every 2nd-column element to be a 1-dimensional array with a size indicated by the first column.
For example: the row [3,""] would become [3,("","","")]
Something like this?
Option Base 1
Sub NestArrays()
Dim OuterArray(3,2) as variant 'create OuterArray with hypothetical numbers 3,5,7
OuterArray(1,1) = 3
OuterArray(2,1) = 5
OuterArray(3,1) = 7
for i = 1 to Ubound(OuterArray) ' for every row in OuterArray
size = OuterArray(i,1) ' set variable "size" equal to the element in 1st column
OuterArray(i,2)=Array(1 to size) ' <--- this doesn't work, set 2nd-col element = array(size)
next i
''''test
OuterArray(1,2)(1) = "aardvark"
debug.print OuterArray(1,2)(1)
End Sub
Use an intermediate array and ReDim as size is dynamic. You possibly want a safeguard on size as well as it needs to be >0 (just a thought)
Option Explicit
Option Base 1
Public Sub NestArrays()
Dim outerArray(3, 2) As Variant, i As Long, size As Long 'create OuterArray with hypothetical numbers 3,5,7
outerArray(1, 1) = 3
outerArray(2, 1) = 5
outerArray(3, 1) = 7
Dim arr()
For i = 1 To UBound(outerArray) ' for every row in OuterArray
size = outerArray(i, 1) ' set variable "size" equal to the element in 1st column
ReDim arr(1 To size)
outerArray(i, 2) = arr
Next i
''''test
outerArray(1, 2)(1) = "aardvark"
Debug.Print outerArray(1, 2)(1)
End Sub
The host array is declared to hold items of type variant. As you can assign an array to a Variant you can proceed as follows
Dim myIndex as long
For Lbound(OuterArray,1) to Ubound(OuterArray,1)
OuterArray(myIndex,2) = Split(String$(OuterArray(myIndex,1),","),",")
Next
If you need the new array to be also an array of variants you will need to create a function that generates the appropriate size of array.
Public Function VarArray(ByVal ipCount As Long) As Variant
Dim mySd As Object
Set mySd = CreateObject("Scripting.DIctionary")
Dim myIndex As Long
For myIndex = 1 To ipCount
mySd.Add myIndex, 0
Next
VarArray = mySd.Items
End Function
So that
OuterArray(myIndex,2) = Split(String$(OuterArray(myIndex,1),","),",")
becomes
OuterArray(myIndex,2) =VarArray(OuterArray(myIndex,1))
I was looking here for the answer to my problem but still, do not know how to solve it so I am refreshing the topic.
I have a primitive function that searches in the Worksheet (column A) the inputs to Userform.TextBox1, UserForm.Textbox2, etc. When a particular record is found, it should assign to an array the record itself and values from next 3 or 4 cells from the same row (each row ends with “End”). In this way, I will have the array of max 4 columns and as many rows as records will be found
The first Do loop goes perfect but increasing the size variable (found records), so increasing the array’s row as I wanted, gives me the subscript out of range error. I spent on this a whole day but I do not see what I am missing.
Here’s the code:
Sub test()
Dim arr() As Variant
Dim i, size As Integer
Dim back As String
Cells(1, 1).Select
i = 0
size = 0
Do Until ActiveCell.Value = UserForm1.TextBox1.Value
ActiveCell.Offset(1, 0).Select
Loop
back = ActiveCell.Address
Do Until ActiveCell = "End"
size = size + 1
ReDim Preserve arr(1 To size, 1 To 4)
Do Until ActiveCell.Value = "End"
i = i + 1
arr(size, i) = ActiveCell
ActiveCell.Offset(0, 1).Select
Loop
Loop
Range(back).Offset(1, 0).Select
Do Until ActiveCell.Value = UserForm1.TextBox2.Value
ActiveCell.Offset(1, 0).Select
Loop
back = ActiveCell.Address
i = 0
Do Until ActiveCell = "End"
size = size + 1
ReDim Preserve arr(1 To size, 1 To 4) '"Subscript out of range" error occurs here
Do Until ActiveCell.Value = "End"
i = i + 1
arr(size, i) = ActiveCell
ActiveCell.Offset(0, 1).Select
Loop
Loop
End Sub
If you use Preserve keyword in an array Redim declaration it will only redimension the last of array's column. You need to reorganize your arr() array.
To restate your algorithm:
Search within the first column for the text in UserForm1.TextBox. This is the start row of a block
Each block continues until "End" appears in the first column
For each row in the block, you want the values of the cells in that row.
A cell which contains "End" marks the end of the values of the cells in that row.
I would suggest the following general improvements:
Use a data structure where you don't have to manage the number of elements, as this is very error-prone. Use a Scripting.Dictionary, an ArrayList or a VBA Collection.
You should not need to manipulate the selected cell. Define a Range and iterate over the cells in the Range.
Like this:
Dim text1 As String
text1 = "Alfa"
Dim text2 As String
text2 = "Kilo"
Dim results As New ArrayList
Dim rng As Range
Set rng = Worksheets("Sheet1").UsedRange
Dim row As Integer
For row = 1 To rng.Rows.Count
Dim firstCellText As String
firstCellText = rng(row, 1)
'you might store the possible values in a Dictionary and use Dictionary.Exists for this check
If firstCellText = text1 Or firstCellText = text2 Then
Dim cellValues As ArrayList
Set cellValues = New ArrayList 'this has to be on a separate line
Dim cell As Range
For Each cell In rng.Rows(row).Cells
If cell = "End" Then Exit For
cellValues.Add cell.Value
Next
results.Add cellValues
End If
Next
I'm trying to create an associative table on a sheet that is pulling in data from a different sheet. By associative I mean, if the data is changed in the source data sheet, it would be reflected on the new sheet. I also want to only have the new sheet's table to be contingent on having a certain unique value. In my case, I want to pull up information related to a part number. The original source data will have many rows that contain the same part number, but I only care to display one of them.
So far, this is what I have:
Function IsInArray(stringToBeFound As String, arr As Variant) As Boolean
Dim bDimen As Byte, i As Long
On Error Resume Next
If IsError(UBound(arr, 2)) Then bDimen = 1 Else bDimen = 2
On Error GoTo 0
Select Case bDimen
Case 1
On Error Resume Next
IsInArray = Application.Match(stringToBeFound, arr, 0)
On Error GoTo 0
Case 2
For i = 1 To UBound(arr, 2)
On Error Resume Next
IsInArray = Application.Match(stringToBeFound,
Application.index(arr, , i), 0)
On Error GoTo 0
If IsInArray = True Then Exit For
Next
End Select
End Function
Sub Part_Separator()
Dim Source As Worksheet
Set Source = Sheets("Part Tracking Scorecard")
Dim ref1(), ref2() As Variant
Dim row, index, lastrow, lastcolumn As Integer
row = 92
lastrow = 866
lastcolumn = 84
ref1 = Source.Range(Source.Cells(row, 1), Source.Cells(lastrow, lastcolumn))
ReDim ref2(UBound(ref1, 1), UBound(ref1, 2))
For index = 0 To (lastrow - row)
If IsInArray(ref1(index, 6).Value, ref2) Then
index = index + 1
Else
ref2(index) = ref1(index) 'copy the entire row from source to ref2
index = index + 1
End If
Next index
Dim NewFile As Worksheet
Set NewFile = Sheets("Unique Parts")
Dim ref2dimension_x, ref2dimension_y As Integer 'find dimensions of ref2 array
ref2dimension_x = UBound(ref2, 1) - LBound(ref2, 1) + 1
ref2dimension_y = UBound(ref2, 2) - LBound(ref2, 2) + 1
For index = 2 To ref2dimension_x 'go through entire new sheet and set values
For index2 = 1 To ref2dimension_y
NewFile.Cells(index, index2).Value = ref2(index - 1, index2)
Next index2
Next index
Erase ref1()
Erase ref2() 'free up the space occupied by these arrays
End Sub
My issue when I run this, I get an error at the first for loop where I'm trying to iterate through my ref1 array, which is the array with all my source data. The error says that my subscript is out of range. This loop is suppose to check if the specific value is in my ref2 array for uniqueness. If the specific value is found, go onto the next row, if not add the row of values associated to the value I'm checking to ref2.