Why cannot be stored my Array? - arrays

I have this code in vba, trying to fill an dynamic array with data extracted from a text file but appears me an error
"subscripts out of range".
I did try to make this with non-zero based arrays but I receive the same error.
Module VBA
option explicit
Sub FromFileToExcel()
Dim Delimiter As String
Dim TextFile As Integer
Dim validRow As Integer
validRow = 0
Dim x As Integer
Dim i As Integer
Dim FilePath As String
Dim FileContent As String
Dim LineArray() As String
Dim DataArray() As String
FilePath = "C:\Users\Jlopez25\Desktop\bertha\INVPLANT.prn"
TextFile = FreeFile
Open FilePath For Input As TextFile
FileContent = Input(LOF(TextFile), TextFile)
Close TextFile
LineArray() = Split(FileContent, vbCrLf)
For x = LBound(LineArray) To UBound(LineArray)
If validateData(LineArray(x)) Then
ReDim Preserve DataArray(validRow, 3) 'here occours the mistake
DataArray(validRow, 1) = Left(LineArray(i), 8)
DataArray(validRow, 2) = Mid(LineArray(i), 9, 7)
DataArray(validRow, 3) = Mid(LineArray(i), 18, 2)
validRow = validRow + 1
End If
Next x
Range("a1").Resize(UBound(DataArray, 1), UBound(DataArray, 2)).Value = DataArray()
End Sub
UDF
Public Function validateData(Data As String) As Boolean
If InStr(1, Left(Data, 8), ":", vbTextCompare) = 0 And _
Len(Replace(Left(Data, 8), " ", "", , , vbTextCompare)) > 7 And _
Left(Data, 1) <> "_" Then
validateData = True
Else
validateData = False
End If
End Function
this are some lines of the text file that I want to separate into DataArray() :
abc:c
page: 1
____________________________
site Location item
MX823JXIA1B38C08 01
MX823JXIA9B06C58 02
MX823JXIA9B12C76 03

ReDim Preserve DataArray(validRow, 3) 'here occours the mistake
that is because you cannot Redim Preserve an Array by changing its first dimension, but only the last dimension. You might want to write your own custom function to achieve this special Redim.
But from your code, I can see that it was possible to calculate the size of the array in a first loop, then do the work in another loop. although it is slow (depends on the complexity of the validateData function), but it easy to achieve. Consider this:
Dim arSize as Integer
For x = LBound(LineArray) To UBound(LineArray)
If validateData(LineArray(x)) Then arsize = arSize + 1
Next
ReDim DataArray(arSize, 1 to 3) 'dimension the array
'And now do the calculation loop
For x = LBound(LineArray) To UBound(LineArray)
If validateData(LineArray(x)) Then
DataArray(validRow, 1) = Left(LineArray(i), 8)
DataArray(validRow, 2) = Mid(LineArray(i), 9, 7)
DataArray(validRow, 3) = Mid(LineArray(i), 18, 2)
validRow = validRow + 1
End If

If you size DataArray to match the size of the input file then you don't really need to keep resizing it. It likely doesn't matter that part of it remains empty...
Option Explicit
Sub FromFileToExcel()
Dim Delimiter As String
Dim validRow As Integer
validRow = 0
Dim x As Integer
Dim i As Integer
Dim FilePath As String
Dim LineArray() As String
Dim DataArray() As String
FilePath = "C:\Users\Jlopez25\Desktop\bertha\INVPLANT.prn"
LineArray() = Split(FileContent(FilePath), vbCrLf)
ReDim DataArray(1 To UBound(LineArray) + 1, 1 To 3)
For x = LBound(LineArray) To UBound(LineArray)
If validateData(LineArray(x)) Then
validRow = validRow + 1
DataArray(validRow, 1) = Left(LineArray(i), 8)
DataArray(validRow, 2) = Mid(LineArray(i), 9, 7)
DataArray(validRow, 3) = Mid(LineArray(i), 18, 2)
End If
Next x
Range("a1").Resize(UBound(DataArray, 1), UBound(DataArray, 2)).Value = DataArray()
End Sub
Public Function validateData(Data As String) As Boolean
If InStr(1, Left(Data, 8), ":", vbTextCompare) = 0 And _
Len(Replace(Left(Data, 8), " ", "", , , vbTextCompare)) > 7 And _
Left(Data, 1) <> "_" Then
validateData = True
Else
validateData = False
End If
End Function
Function FileContent(sPath As String) As String
Dim TextFile As Integer
TextFile = FreeFile
Open FilePath For Input As TextFile
FileContent = Input(LOF(TextFile), TextFile)
Close TextFile
End Function

Related

Find duplicates in 2D arrays in VBA

I want a cod that will find duplicates and return it in separate array.
So I found a code that would be perfect for me, but the thing is that this code is removing duplicates. I thought that it will be a simple job to change it, but somehow I cannot manage to do it....
I was thinking that it will be in this part of code If Err.Number <> 0 Then coll.Remove txt but have no idea how to change it. I have tried changing <> with = but it seems not to work.
Can someone tell me where and how should I change the code to get duplicates from 2 arrays.
Sub test()
Dim arr1 As Variant
Dim arr2 As Variant
Dim arr3 As Variant
Dim coll As Collection
Dim I As Long, j As Long, ii As Long, txt As String, x
With Worksheets("Sheet1")
LastRowColumnA = .Cells(.Rows.Count, 1).End(xlUp).Row
arr1 = .Range("A2:C" & LastRowColumnA).Value
End With
With Worksheets("Sheet2")
LastRowColumnA = .Cells(.Rows.Count, 1).End(xlUp).Row
arr2 = .Range("A2:C" & LastRowColumnA).Value
End With
Set coll = New Collection
On Error Resume Next
For I = LBound(arr1, 1) To UBound(arr1, 1)
txt = Join(Array(arr1(I, 1), arr1(I, 2), arr1(I, 3)), Chr(2))
coll.Add txt, txt
Next I
For I = LBound(arr2, 1) To UBound(arr2, 1)
txt = Join(Array(arr2(I, 1), arr2(I, 2), arr2(I, 3)), Chr(2))
Err.Clear
coll.Add txt, txt
If Err.Number <> 0 Then coll.Remove txt
Next I
ReDim arr3(1 To coll.Count, 1 To 3)
For I = 1 To coll.Count
x = Split(coll(I), Chr(2))
For ii = 0 To 2
arr3(I, ii + 1) = x(ii)
Next
Next I
Worksheets("test").Range("A2").Resize(UBound(arr3, 1), 3).Value = arr3
Columns("A:C").EntireColumn.AutoFit
End Sub
Regards,
Timonek
Extract Duplicates
If you set CountSameWorksheetDuplicates to True, it will return the duplicates of each worksheet even if they are not found in the other worksheet.
Option Explicit
Sub ExtractDuplicates()
Const sName1 As String = "Sheet1"
Const sCols1 As String = "A:C"
Const sfRow1 As Long = 2
Const sName2 As String = "Sheet2"
Const sCols2 As String = "A:C"
Const sfRow2 As Long = 2
Const dName As String = "Test"
Const dfCellAddress As String = "A2"
Const CountSameWorksheetDuplicates As Boolean = False
Dim Delimiter As String: Delimiter = Chr(2)
Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
Dim sData As Variant
sData = RefColumns(wb.Worksheets(sName1).Rows(sfRow1).Columns(sCols1))
Dim cCount As Long: cCount = UBound(sData, 2)
Dim dict As Object: Set dict = CreateObject("Scripting.Dictionary")
dict.CompareMode = vbTextCompare
Dim r As Long
Dim sKey As Variant
For r = 1 To UBound(sData, 1)
sKey = StrJoinedDataRow(sData, r, Delimiter)
If CountSameWorksheetDuplicates Then
DictAddCount dict, sKey
Else
DictAdd dict, sKey, 1
End If
Next r
sData = RefColumns(wb.Worksheets(sName2).Rows(sfRow2).Columns(sCols2))
If CountSameWorksheetDuplicates Then
For r = 1 To UBound(sData, 1)
sKey = StrJoinedDataRow(sData, r, Delimiter)
DictAddCount dict, sKey
Next r
Else
Dim dict2 As Object: Set dict2 = CreateObject("Scripting.Dictionary")
dict2.CompareMode = vbTextCompare
For r = 1 To UBound(sData, 1)
sKey = StrJoinedDataRow(sData, r, Delimiter)
DictAdd dict2, sKey
Next r
For Each sKey In dict2.Keys
DictAddCount dict, sKey
Next sKey
Set dict2 = Nothing
End If
Erase sData
For Each sKey In dict.Keys
If dict(sKey) = 1 Then dict.Remove sKey
Next sKey
Dim drCount As Long: drCount = dict.Count
If drCount = 0 Then Exit Sub
Dim dData As Variant: ReDim dData(1 To drCount, 1 To cCount)
r = 0
Dim c As Long
For Each sKey In dict.Keys
sData = Split(sKey, Delimiter)
r = r + 1
For c = 1 To cCount
dData(r, c) = sData(c - 1)
Next c
Next sKey
Dim drg As Range
Set drg = wb.Worksheets(dName).Range(dfCellAddress).Resize(drCount, cCount)
drg.Value = dData
drg.Resize(drg.Worksheet.Rows.Count - drg.Row - drCount + 1) _
.Offset(drCount).Clear ' clear below
drg.EntireColumn.AutoFit
End Sub
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Purpose: Creates a reference to the range from the first row of a range
' ('FirstRowRange') to the row range containing
' the bottom-most non-empty cell in the row's columns.
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Function RefColumns( _
ByVal FirstRowRange As Range) _
As Range
If FirstRowRange Is Nothing Then Exit Function
With FirstRowRange.Rows(1)
Dim lCell As Range
Set lCell = .Resize(.Worksheet.Rows.Count - .Row + 1) _
.Find("*", , xlFormulas, , xlByRows, xlPrevious)
If lCell Is Nothing Then Exit Function ' empty range
Set RefColumns = .Resize(lCell.Row - .Row + 1)
End With
End Function
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Purpose: Returns the values of a row of a 2D array in a delimited string.
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Function StrJoinedDataRow( _
ByVal Data As Variant, _
ByVal RowIndex As Long, _
Optional ByVal Delimiter As String = " ") _
As String
Const ProcName As String = "StrJoinedDataRow"
On Error GoTo ClearError
Dim c As Long
Dim cString As String
For c = LBound(Data, 2) To UBound(Data, 2)
cString = cString & CStr(Data(RowIndex, c)) & Delimiter
Next c
StrJoinedDataRow = Left(cString, Len(cString) - Len(Delimiter))
ProcExit:
Exit Function
ClearError:
Debug.Print "'" & ProcName & "' Run-time error '" _
& Err.Number & "':" & vbLf & " " & Err.Description
Resume ProcExit
End Function
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Purpose: Adds a value ('Key') to a key of an existing ('ByRef')
' dictionary ('dict') adding another value ('Item')
' to the key's associated item.
' Remarks: Error and blank values are excluded.
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Sub DictAdd( _
ByRef dict As Object, _
ByVal Key As Variant, _
Optional ByVal Item As Variant = Empty)
If Not IsError(Key) Then
If Len(Key) > 0 Then
dict(Key) = Item
End If
End If
End Sub
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Purpose: Adds a value ('Key') to a key of an existing ('ByRef')
' dictionary ('dict') increasing its count being held
' in the key's associated item.
' Remarks: Error and blank values are excluded.
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Sub DictAddCount( _
ByRef dict As Object, _
ByVal Key As Variant)
If Not IsError(Key) Then
If Len(Key) > 0 Then
dict(Key) = dict(Key) + 1
End If
End If
End Sub
Dim Dict as Object
Dict = CreateObject("Scripting.Dictionary")
Dim Line As Object
For Each line in MyArray
On Error Resume Next
Dict.Add(Line, "")
On Error Goto 0
Next
Dictionaries don't allow duplicate keys. We are only setting keys and ignoring the value by not setting it. The dictionary raises an error if the key exists.

Is VBA able to store each array individually and wait to print them to a template?

Is there a way to have this script form the entire array based off the rows I want it to extract based on the IF Statement?
I know this finds a name on the Mgrs worksheet, and finds those rows in the Data worksheet, but then it directly prints it after forming the array. Can I have this code store all of the data, and then wait to print the data on a template that I format myself?
Option Explicit
Sub CIB_Cuts()
Dim j As Long, k As Long, x As Long
Dim varArray() As Variant
Dim varArray2() As Variant
ReDim varArray(1 To 19, 1 To 1)
Dim strManager As String, strEC As String, strLogin As String
Dim BASEPATH As String, strNewPath As String, strFileName As String
Dim Wb As Workbook
Dim mgrRow As Long
Dim colManager As Long
colManager = 3
Dim colLogin As Long
colLogin = 4
Dim colEC As Long
colEC = 5
BASEPATH = "M:\Final Files\"
Call speedupcode(True)
For mgrRow = 2 To ThisWorkbook.Worksheets("Mgrs").UsedRange.Rows.Count
If ThisWorkbook.Worksheets("Mgrs").Cells(mgrRow, 3) <> "" Then
strManager = ThisWorkbook.Worksheets("Mgrs").Cells(mgrRow, 3)
With ThisWorkbook.Worksheets("Data")
ReDim varArray(1 To UBound(varArray, 1), 1 To 1)
x = 1
For k = 1 To UBound(varArray, 1)
varArray(k, x) = .Cells(1, k)
Next
For j = 2 To .UsedRange.Rows.Count + 1
If strManager = .Cells(j, colManager) Then
x = x + 1
ReDim Preserve varArray(1 To UBound(varArray, 1), 1 To x)
For k = 1 To UBound(varArray, 1)
If k = 1 Then
varArray(1, x) = CStr(Format(.Cells(j, k), "000000000"))
Else
varArray(k, x) = .Cells(j, k)
End If
strEC = .Cells(j, colEC)
strManager = .Cells(j, colManager)
strLogin = .Cells(j, colLogin)
Next
End If
Next
End With
strFileName = strLogin & " - " & strManager & " - " & "Shift Differential Validation" & ".xlsx"
ReDim varArray2(1 To UBound(varArray, 2), 1 To UBound(varArray, 1))
Set Wb = Workbooks.Add(XlWBATemplate.xlWBATWorksheet)
With Wb
With .Worksheets("Sheet1")
.Columns(1).NumberFormat = "#"
.Columns(15).NumberFormat = "0%"
For j = 1 To UBound(varArray, 2)
For k = 1 To UBound(varArray, 1)
varArray2(j, k) = varArray(k, j)
Next
Next
.Range(.Cells(1, 1), .Cells(UBound(varArray, 2), UBound(varArray, 1))) = varArray2
Call DataValidation
Call Header
.Range("C2").Select
ActiveWindow.FreezePanes = True
.Cells.EntireColumn.AutoFit
.Rows("1:1").Font.Bold = True
Call protect
End With
.SaveAs strNewPath & strFileName, Password:="password", FileFormat:=51
.Saved = True
.Close
End With
Set Wb = Nothing
End If
Next
Call speedupcode(False)
End Sub
You could store the array each time in an overarching array or a collection and loop that at the end...
Public Sub test()
Dim varArray2() As Variant, results As Collection
'other code..
Set results = New Collection
results.Add varArray2
End Sub
You could also use Select Case , or something distinctive during the loop, to determine a key and populate a dictionary with the arrays as values which might make retrieval of specific items easier.

Manipulating workbook data with two arrays

I am trying to get the information from one workbook, transform it to array (2D), add the first column (identifier) to an identifier array, match and paste it to excel. The code has some extra lines for basic organization.
The current problem is that, in the IsInArray function, I am getting a "subscript not defined", for the 'for position = LBound(arr) to UBound(arr)'.
Any idea of what might be happening?
Sub Pr()
Dim w As Workbook
Set w = ThisWorkbook
Dim w2 As Workbook
Dim end1 As Long, end2 As Long, i As Long, lRow As Long, lColumn As Long, t As Long, k As Long, position As Long, g As Long
Dim WBArray() As Variant
Dim IS() As Variant
Dim ws As Worksheet
end1 = ThisWorkbook.Worksheets(1).UsedRange.Rows.count
Dim MyFolder As String
Dim MyFile As String
'Optimize Macro Speed Start
Application.ScreenUpdating = False
Application.EnableEvents = False
Application.Calculation = xlCalculationManual
'opens the first workbook file
For i = 2 To ThisWorkbook.Sheets("FILES").Cells(1, 2).Value
Workbooks.Open Filename:=ThisWorkbook.path & "\" & ThisWorkbook.Sheets("FILES").Cells(i, 1).Value
Set w2 = ActiveWorkbook
ActiveSheet.Range("A:A").Select
'text to columns
Selection.TextToColumns destination:=Range("A1"), DataType:=xlDelimited, TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=True, _
Semicolon:=True, Comma:=True, Space:=False, Other:=False, FieldInfo:=Array(Array(1, 1), Array(2, 1), Array(3, 1), Array(4, 1), Array(5, 1), Array(6, 1), Array(7 _
, 1), Array(8, 1), Array(9, 1), Array(10, 1), Array(11, 1), Array(12, 1), Array(13, 1), Array(14, 1), Array(15, 1), Array(16, 1), Array(17 _
, 1), Array(18, 1), Array(19, 1), Array(20, 1), Array(21, 1), Array(22, 1), Array(23, 1), Array(24, 1), Array(25, 1), Array(26, 1), Array(27 _
, 1), Array(28, 1), Array(29, 1), Array(30, 1), Array(31, 1), Array(32, 1)), TrailingMinusNumbers:=True
end2 = ActiveSheet.UsedRange.Rows.count
'transform it to array
WBArray = ActiveSheet.Range(Cells(5, 1), Cells(end2, 29)).Value
'loop to match information in two arrays
For lRow = 2 To UBound(WBArray)
If IsInArray((WBArray(lRow, 1)), IS) <> -1 Then
t = IsInArray((WBArray(lRow, 1)), IS)
'start the information pasting procedure:
w.Sheets("C").Cell(t, i + 3) = WBArray(lRow, 11)
w.Sheets("M").Cell(t, i + 3) = WBArray(lRow, 12)
w.Sheets("W t-1").Cell(t, i + 3) = WBArray(lRow, 13)
w.Sheets("P").Cell(t, i + 3) = WBArray(lRow, 14)
w.Sheets("A").Cell(t, i + 3) = WBArray(lRow, 15)
w.Sheets("PC").Cell(t, i + 3) = WBArray(lRow, 16)
w.Sheets("AM").Cell(t, i + 3) = WBArray(lRow, 17)
w.Sheets("AM t-1").Cell(t, i + 3) = WBArray(lRow, 18)
w.Sheets("P t-1").Cell(t, i + 3) = WBArray(lRow, 19)
w.Sheets("F").Cell(t, i + 3) = WBArray(lRow, 20)
w.Sheets("F t-1").Cell(t, i + 3) = WBArray(lRow, 21)
w.Sheets("A t-1").Cell(t, i + 3) = WBArray(lRow, 22)
w.Sheets("S").Cell(t, i + 3) = WBArray(lRow, 23)
Else
'add it to the end of ISArray
ReDim Preserve IS(1 To UBound(IS) + 1)
IS(UBound(IS)) = WBArray(lRow, 1)
k = UBound(IS)
w.Sheets("C").Cell(k, i + 3) = WBArray(lRow, 11)
w.Sheets("M").Cell(k, i + 3) = WBArray(lRow, 12)
w.Sheets("W t-1").Cell(k, i + 3) = WBArray(lRow, 13)
w.Sheets("P").Cell(k, i + 3) = WBArray(lRow, 14)
w.Sheets("A").Cell(k, i + 3) = WBArray(lRow, 15)
w.Sheets("PC").Cell(k, i + 3) = WBArray(lRow, 16)
w.Sheets("AM").Cell(k, i + 3) = WBArray(lRow, 17)
w.Sheets("AM t-1").Cell(k, i + 3) = WBArray(lRow, 18)
w.Sheets("P t-1").Cell(k, i + 3) = WBArray(lRow, 19)
w.Sheets("F").Cell(k, i + 3) = WBArray(lRow, 20)
w.Sheets("F t-1").Cell(k, i + 3) = WBArray(lRow, 21)
w.Sheets("A t-1").Cell(k, i + 3) = WBArray(lRow, 22)
w.Sheets("S").Cell(k, i + 3) = WBArray(lRow, 23)
End If
Next lRow
'copy the file date from each source workbook to output workbook
'if the control sheet name (FILES) is changed, please change it in this loop
For Each ws In w.Worksheets
If ws.Name <> "FILES" Then
ws.Cells(1, i + 3) = w2.Worksheets(1).Cells(1, 2)
End If
Next ws
Next i
'paste the is array to all worksheets
g = UBound(IS)
For Each ws In ActiveWorkbook.Worksheets
Range("A1:A" & g) = IS()
Next ws
'Optimize Macro Speed
Application.ScreenUpdating = True
Application.EnableEvents = True
Application.Calculation = xlCalculationAutomatic
'Close file and save
'w.Close True
End Sub
Function IsInArray(stringToBeFound As String, arr As Variant) As Long
Dim position As Long
'default return value if value not found in array
IsInArray = -1
For position = LBound(arr) To UBound(arr) 'subscript out of range
If arr(position) = stringToBeFound Then
IsInArray = position + 1
Exit For
End If
Next
End Function
Your problem is that when you test the LBOUND of an unallocated array, you will get an error. And that will be the case on the first pass through your IsInArray function.
Since links to outside websites are discouraged, I have copied the IsArrayEmpty function from Chip Pearson's web site page on VBA Arrays
Change your IsInArray function as follows (and add the IsArrayEmpty function as I show below:
Function IsInArray(stringToBeFound As String, Arr As Variant) As Long
Dim position As Long
'default return value if value not found in array
IsInArray = -1
If IsArrayEmpty(Arr) Then Exit Function
For position = LBound(Arr) To UBound(Arr) 'subscript out of range
If Arr(position) = stringToBeFound Then
IsInArray = position + 1
Exit For
End If
Next
End Function
Public Function IsArrayEmpty(Arr As Variant) As Boolean
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'From Chip Pearson [VBA Arrays](http://www.cpearson.com/excel/vbaarrays.htm)
' IsArrayEmpty
' This function tests whether the array is empty (unallocated). Returns TRUE or FALSE.
'
' The VBA IsArray function indicates whether a variable is an array, but it does not
' distinguish between allocated and unallocated arrays. It will return TRUE for both
' allocated and unallocated arrays. This function tests whether the array has actually
' been allocated.
'
' This function is really the reverse of IsArrayAllocated.
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Dim LB As Long
Dim UB As Long
Err.Clear
On Error Resume Next
If IsArray(Arr) = False Then
' we weren't passed an array, return True
IsArrayEmpty = True
End If
' Attempt to get the UBound of the array. If the array is
' unallocated, an error will occur.
UB = UBound(Arr, 1)
If (Err.Number <> 0) Then
IsArrayEmpty = True
Else
''''''''''''''''''''''''''''''''''''''''''
' On rare occassion, under circumstances I
' cannot reliably replictate, Err.Number
' will be 0 for an unallocated, empty array.
' On these occassions, LBound is 0 and
' UBoung is -1.
' To accomodate the weird behavior, test to
' see if LB > UB. If so, the array is not
' allocated.
''''''''''''''''''''''''''''''''''''''''''
Err.Clear
LB = LBound(Arr)
If LB > UB Then
IsArrayEmpty = True
Else
IsArrayEmpty = False
End If
End If
End Function
In your function IsInArray, can you try this :
Function IsInArray(stringToBeFound As String, arr As Variant) As Long
Dim position As Long
Dim returnValue as Long
'default return value if value not found in array
returnValue = -1
For position = LBound(arr) To UBound(arr) 'subscript out of range
If arr(position) = stringToBeFound Then
returnValue = position + 1
Exit For
End If
Next
IsInArray = returnValue
End Function`
I think when you write : IsInArray = -1, you're ending your function.

Excel 2010 VBA - Split String by Comma, Skip Blank Results

I am using the following code to chop up a column of comma-separated lists and to return each entry in a new row:
Sub SliceNDice()
'
' Splits the locations cells according to commas and pushes to new rows
' Code courtesy of brettdj (http://stackoverflow.com/questions/8560718/split-comma-separated-entries-to-new-rows)
'
Dim objRegex As Object
Dim x
Dim Y
Dim lngRow As Long
Dim lngCnt As Long
Dim tempArr() As String
Dim strArr
Set objRegex = CreateObject("vbscript.regexp")
objRegex.Pattern = "^\s+(.+?)$"
'Define the range to be analysed
x = Range([a1], Cells(Rows.Count, "c").End(xlUp)).Value2
ReDim Y(1 To 3, 1 To 1000)
For lngRow = 1 To UBound(x, 1)
'Split each string by ","
tempArr = Split(x(lngRow, 3), ",")
For Each strArr In tempArr
lngCnt = lngCnt + 1
'Add another 1000 records to resorted array every 1000 records
If lngCnt Mod 1000 = 0 Then ReDim Preserve Y(1 To 3, 1 To lngCnt + 1000)
Y(1, lngCnt) = x(lngRow, 1)
Y(2, lngCnt) = x(lngRow, 2)
Y(3, lngCnt) = objRegex.Replace(strArr, "$1")
Next
Next lngRow
'Dump the re-ordered range to columns E:G
[e1].Resize(lngCnt, 3).Value2 = Application.Transpose(Y)
End Sub
While this code works perfectly, it has a fatal flaw in that any double-commas in the cells of column C will result in blank cells pushed to the new rows in column G.
Does anyone know how to edit the code so that it does not create new rows with empty cells in column G, but skips them and enters the next rows in their places as if the superfluous commas were never included in column C at all?
Just test for the string length of strArr as the first operation inside the For Each strArr In tempArr loop.
For Each strArr In tempArr
If CBool(Len(strArr)) Then
lngCnt = lngCnt + 1
'Add another 1000 records to resorted array every 1000 records
If lngCnt Mod 1000 = 0 Then ReDim Preserve Y(1 To 3, 1 To lngCnt + 1000)
Y(1, lngCnt) = x(lngRow, 1)
Y(2, lngCnt) = x(lngRow, 2)
Y(3, lngCnt) = objRegex.Replace(strArr, "$1")
End If
Next strArr
You could loop on the occurence of double comma to clean up the input as opposed to fixing the output, here is a working example:
Text in A1: Hello,,World,This,,Is,,,,,,,A,,Test
Sub TestString()
Dim MyString As String
MyString = Range("A1").Text
Do Until Len(MyString) = Len(Replace(MyString, ",,", ","))
MyString = Replace(MyString, ",,", ",")
Loop
MsgBox MyString
End Sub
You would do this just before splitting
If you want it as a function (would be better in your case) do this:
Function FixDoubleComma(MyString As String)
Do Until Len(MyString) = Len(Replace(MyString, ",,", ","))
MyString = Replace(MyString, ",,", ",")
Loop
FixDoubleComma = MyString
End Function
Then replace this in your code:
tempArr = Split(x(lngRow, 3), ",")
With this:
tempArr = Split(FixDoubleComma(x(lngRow, 3)), ",")
I have a little sample that solves blanks everywhere
Sub RemoveBlanks()
Dim mystr As String
Dim arrWithBlanks() As String
Dim arrNoBlanks() As String
Dim i As Integer
mystr = ",tom,jerry, ,,spike,," 'Blanks everywhere (beginning, middle and end)
arrWithBlanks = Split(mystr, ",")
ReDim arrNoBlanks(0 To 0)
Debug.Print "Array with blanks:"
'Loop through the array with blanks
For i = LBound(arrWithBlanks) To UBound(arrWithBlanks)
'Check if there is a blank (or element with spaces only)
If Trim(arrWithBlanks(i)) = "" Then
Debug.Print i & " (blank)"
Else
Debug.Print i & " " & arrWithBlanks(i)
If arrNoBlanks(UBound(arrNoBlanks)) <> "" Then ReDim Preserve arrNoBlanks(0 To UBound(arrNoBlanks) + 1)
arrNoBlanks(UBound(arrNoBlanks)) = arrWithBlanks(i)
End If
Next i
Debug.Print "Array with NO blanks:"
For i = LBound(arrNoBlanks) To UBound(arrNoBlanks)
Debug.Print i & " " & arrNoBlanks(i)
Next i
End Sub
Everything will be displayed in the immediate window (Press Ctrl + G to show it)
The result will look like this:
Array with blanks:
0 (blank)
1 tom
2 jerry
3 (blank)
4 (blank)
5 spike
6 (blank)
7 (blank)
Array with NO blanks:
0 tom
1 jerry
2 spike

Error in searching for an array data type string within a range

I have an array of strings. I also had a worksheet containing two columns, first column contains the strings from my array and the second column contains the numeric code associated with the first column.
I need for a subset of the array to find, their associated codes. I tried the following but it does not work.
Dim Data(1000, 1000) as string
.Range("B:B").Find(what:=Data(j,1), LookIn:=xlValues, SearchOrder:=xlByRows, MatchCase:=False).Row
I checked to see why I get error and I noticed it does not recognize Data(j,1) as it's string value. The value in Data(j,1) (for j=1) is Sch_agr_Tor. If I replace Data(j,1) with the string "Sch_agr_Tor" it is fine, however that's not practical as I want to use the loop and cannot manually use "find".
In the immediate window I checked and got the following:
? TypeName(Data(j,1))
String
? Data(j,1)
Sch_agr_Tor
? Data(j,1)="Sch_agr_Tor"
False
? Data(j,1)=Sch_agr_Tor
False
I thought it might be internal bug of the Find. So I wrote my own find function.
Function FindRow(Rng As Range, Exp As String) As Long
Dim vArr As Variant
Dim j As Long
Dim n As Long
Dim c As Range
n = 0
For Each c In Rng
If Exp = c.value Then
n = c.Row
Exit For
End If
Next c
FindRow = n
End Function
However now when I change "Exp As String" argument in the FindRow function to "Exp As Variant" it will returns zero.
n = FindRow(UserSheet.Range(Cells(1, 2), Cells(Cells(Rows.Count, 2).End(xlUp).Row, 2)), Data(j, 1))
If I enter
n = FindRow(UserSheet.Range(Cells(1, 2), Cells(Cells(Rows.Count, 2).End(xlUp).Row, 2)), "Sch_agr_Tor")
I get the right answer which is 39.
Here is the header and the rest of the code:
Option Explicit
Option Base 1
Sub main()
Dim MainWorkbook As Workbook
Dim MainSheet, UserTableSheet, InputSheet, OutputSheet, TradesSheet, InitialSheet As Worksheet
Dim targetCellLoc As String
Dim fileName As String
Dim addressName As String
Dim originCellLoc, Str As String
Dim i, j, NumRuns As Integer
Dim t_start, t_end As Double
Dim FirstCol, LastCol, n As Integer
Dim Data() As Variant
' Initialize the variables
Set MainWorkbook = Application.ThisWorkbook
Set InitialSheet = MainWorkbook.ActiveSheet
Set MainSheet = MainWorkbook.Sheets("Sheet1")
i = 2
Do While MainSheet.Cells(11, i).value <> ""
Set UserTableSheet = MainWorkbook.Sheets(MainSheet.Cells(11, i).value)
Set InputSheet = MainWorkbook.Sheets(MainSheet.Cells(12, i).value)
With InputSheet
FirstCol = .Range("1:1").Find(what:="Collateral Agreement Group:", LookIn:=xlValues, SearchOrder:=xlByColumns, MatchCase:=False).Column
LastCol = .Cells(1, .Columns.Count).End(xlToLeft).Column
End With
'creating an array for our data with the right dimension
ReDim Data(LastCol - FirstCol + 1, 6)
For j = 1 To UBound(Data, 1)
Data(j, 1) = Mid(InputSheet.Cells(1, FirstCol + j - 1).value, 28, 1 + Len(InputSheet.Cells(1, FirstCol + j - 1).value) - 28)
MainWorkbook.Sheets("Sheet4").Cells(j, 1) = Data(j, 1)
n = FindRow(UserTableSheet.Range(Cells(2, 2), Cells(Cells(Rows.Count, 2).End(xlUp).Row, 2)), Data(j, 1))
Data(j, 2) = UserTableSheet.Cells(n, 4)
Next j
i = i + 1
Loop
End Sub
Make sure you are on the correct Worksheet. This adaptation of your code appears to work:
Sub qwerty()
Dim Data(1000, 1000) As String
Dim r As Range
Data(1, 1) = "Sch_agr_Tor"
j = 1
Set r = Range("B:B").Find(what:=Data(j, 1), LookIn:=xlValues, SearchOrder:=xlByRows, MatchCase:=False)
MsgBox r.Row
End Sub
EDIT#1:
Other than being on the correct worksheet, there are two other things that might go wrong:
starting from the wrong location
trying to match a whole cell instead of part of the cell
For example:
Sub qwerty()
Dim Data(1000, 1000) As String
Dim r As Range
Data(1, 1) = "Sch_agr_Tor"
j = 1
Set r = Range("B:B").Find( _
what:=Data(j, 1), _
LookIn:=xlValues, _
SearchOrder:=xlByRows, _
MatchCase:=False, _
After:=Range("B1"), _
LookAt:=xlPart)
MsgBox r.Row
End Sub

Resources