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.
Related
Using the below Boolean function to check if the cell value equals "M8D" or "M8P" or "M20")
Function m8_field(ByVal plf As String) As Boolean
m8_field = (plf = "M8D" Or plf = "M8P" Or plf = "M20")
End Function
And I use it like below and it works:
Dim arg As Range: Set arg = ActiveSheet.Range("D1:E20")
Dim arr: arr = arg.Value2
Dim r As Long
For r = 1 To UBound(arr)
If m8_field(arr(r, 2)) Then arr(r, 1) = "Good"
Next
What I need to change the last line :
If m8_field(arr(r, 2)) Then arr(r, 1) = "Good"
Into
If arr(r, 2) = m8_field Then arr(r, 1) = "Good"
But I got
Compile error:Argument not optional on this part (m8_field)
In advance any learning help will be appreciated
Flag When a String From a List Matches
If you would use a function, it would read the array of strings each time per row making it inefficient.
Sub m8_field_Sub()
Const GoodStringsList As String = "M8D,M8P,M20"
Dim GoodStrings() As String: GoodStrings = Split(GoodStringsList, ",")
Dim arg As Range: Set arg = ActiveSheet.Range("D1:E20")
Dim arr As Variant: arr = arg.Value2
Dim r As Long
For r = 1 To UBound(arr, 1)
If IsNumeric(Application.Match(CStr(arr(r, 2)), GoodStrings, 0)) Then
arr(r, 1) = "Good"
'Else
' arr(r, 1) = "Bad" ' or e.g. arr(r, 1) = ""
End If
Next
' Write back to the range.
'arg.Value = arr
End Sub
If you wanna get 'fancy' about it:
Function GetGoodStrings() As String()
Const GoodStringsList As String = "M8D,M8P,M20"
GetGoodStrings = Split(GoodStringsList, ",")
End Function
Function m8_field(ByVal plf As String, GoodStrings() As String) As Boolean
m8_field = IsNumeric(Application.Match(plf, GoodStrings, 0))
End Function
Sub TestTheFunctions()
' Read only once.
Dim GoodStrings() As String: GoodStrings = GetGoodStrings
Dim arg As Range: Set arg = ActiveSheet.Range("D1:E20")
Dim arr As Variant: arr = arg.Value2
Dim r As Long
Dim plf As String
For r = 1 To UBound(arr, 1)
plf = CStr(arr(r, 2))
If m8_field(plf, GoodStrings) Then ' needs parameters
arr(r, 1) = "Good"
'Else
' arr(r, 1) = "Bad" ' or e.g. arr(r, 1) = ""
End If
Next
' Write back to the range.
'arg.Value = arr
End Sub
My goal is to select a column of about 300,000 cells and round each cell's value to two decimal places.
I found that looping an array is far faster than looping through cells.
It is much faster if I have the whole array post its data into the cells after the loop rather than during because again posting any data in a loop takes too much time.
Is there a way to write all the values from the new array ("varArray") after the loop is completed?
Sub RoundedTwoDecimalPlaces()
Dim i As Integer
Dim MyArray() As Variant ' Declare dynamic array.
Dim LastRow As Integer
Dim lStart As Double
Dim lEnd As Double
lStart = Timer
LastRow = Cells(1, Selection.Column).End(xlDown).Row
MyArray = Range("a1:a8").Value2
ReDim MyArray(LastRow) ' Resize to x amount of elements.
For i = 1 To LastRow
MyArray(i) = Round(Cells(i, Selection.Column), 2) ' Initialize array.
Next i
''this is where I can't get my array to post into the cells dynamically.
Selection.Value = MyArray()
''to see the amount of time it takes to finish.
'' My goal is to do 300,000 lines quickly
lEnd = Timer
Debug.Print "Duration = " & (lEnd - lStart) & " seconds"
End Sub
You can get the array directly from the range and then restore the altered values:
Sub RoundedTwoDecimalPlaces()
Dim i As Integer
Dim arr As Variant
Dim lStart As Double
Dim ws As Worksheet, col as Long
Set ws = ActiveSheet
col = Selection.Column
lStart = Timer
With ws.Range(ws.Cells(1, col), ws.Cells(1, col).End(xlDown))
arr = .Value
For i = 1 to Ubound(arr, 1)
arr(i, 1) = Round(arr(i, 1), 2)
Next i
.Value = arr
end with
Debug.Print "Duration = " & (Timer - lStart) & " seconds"
End Sub
Here is how I did it using #Tim Williams Code.
I had to loop it because the array has a max character limit.
Here is the finished code:
Sub loopthrough()
Dim i As Integer
Dim arr As Variant
Dim arr1 As Variant
Dim arr2 As Variant
Dim lStart As Double
Dim ws As Worksheet, col As Long
LastRow = Cells(1, Selection.Column).End(xlDown).Row
Set ws = ActiveSheet
col = Selection.Column
lStart = Timer
If LastRow < 30001 Then
With ws.Range(ws.Cells(1, col), ws.Cells(1, col).End(xlDown))
arr = .Value2
For i = 1 To UBound(arr, 1)
If IsNumeric(arr(i, 1)) Then
arr(i, 1) = Round(arr(i, 1), 2)
Else
arr(i, 1) = arr(i, 1)
End If
Next i
.Value2 = arr
End With
Else ''if selection is more than 30,000 lines.
n = 1
Z = 30000
Do While Z < LastRow
With ws.Range(ws.Cells(n, col), ws.Cells(Z, col))
arr = .Value2
For i = 1 To UBound(arr, 1)
If IsNumeric(arr(i, 1)) Then
arr(i, 1) = Round(arr(i, 1), 2)
Else
arr(i, 1) = arr(i, 1)
End If
Next i
.Value2 = arr
End With
n = n + 30000
Z = Z + 30000
Loop
With ws.Range(ws.Cells(n, col), ws.Cells(n, col).End(xlDown))
arr = .Value2
For i = 1 To UBound(arr, 1)
If IsNumeric(arr(i, 1)) Then
arr(i, 1) = Round(arr(i, 1), 2)
Else
arr(i, 1) = arr(i, 1)
End If
Next i
.Value2 = arr
End With
End If
Debug.Print "Duration = " & (Timer - lStart) & " seconds"
End Sub
first of all, i'd like to say, i've sarched thorugh the net, but i haven't run into such a thing. i've seen collection of collections, or array of arrays, but not a collection of array.
what i want to do is, to collect ID's in collections for each District. Finally, i will join the values in the collections with Join function and ";" as delimiter, and then print them in a range of 4 column as a lookup list, for each class. For example;
Class2(0) will include 54020 and 30734, class2(1) will include 58618, class1(4) will include none, class3(7) will include 35516,34781 and 56874, and so on.
i want to loop through column C and put a select case statment to check the class and then assign the values to collections
Sub dict_coll()
Dim class1() As New Collection
Dim class2() As New Collection
Dim class3() As New Collection
Dim class4() As New Collection
Dim dict As New Scripting.Dictionary
Set dRange = range(range("a2"), range("a2").End(xlDown))
i = 0
For Each d In dRange
If Not dict.Exists(d.Value) Then
dict.Add key:=d.Value, item:=i
i = i + 1
End If
Next d
Set cRange = range(range("c2"), range("c2").End(xlDown))
For Each c In cRange
Select Case c.Value
Case "class1"
class1(dict(c.offset(0,-2).value)).Add c.Offset(0, 1).Value 'fails here
Case "class2"
class2(dict(c.offset(0,-2).value)).Add c.Offset(0, 1).Value 'fails here
Case "class3"
class3(dict(c.offset(0,-2).value)).Add c.Offset(0, 1).Value 'fails here
Case Else
class4(dict(c.offset(0,-2).value)).Add c.Offset(0, 1).Value 'fails here
End Select
Next c
End Sub
and what i want to see is as foloowing:
is there any easier and proper way of what i wanna do? any help wil be appreciated.
thanks
I didnt see that sb variable defined in your code.
Anyway, for me I see a case of straightforward arrays: There is fixed dimension of classes so it good enough for me. Furthermore, you can print back to worksheet so easily.
Public Sub test()
Const strPrefix = "class"
Dim districtRange As Range, outputRange As Range, r As Range
Dim arr() As String
Dim i As Long, j As Long, x As Long, y As Long
Dim district As String, str As String, idVal As String
Dim arr2 As Variant
Application.ScreenUpdating = False
ReDim arr(1 To 5, 1 To 1)
arr(1, 1) = "District"
arr(2, 1) = "Class 1"
arr(3, 1) = "Class 2"
arr(4, 1) = "Class 3"
arr(5, 1) = "Class 4"
Set districtRange = Range(Range("A2"), Range("C2").End(xlDown))
arr2 = districtRange.Value
For x = LBound(arr2, 1) To UBound(arr2, 1)
district = arr2(x, 1)
i = Val(Mid(arr2(x, 3), Len(strPrefix) + 1))
idVal = arr2(x, 2)
j = inArray(arr, district, 1) 'returns -1 if not found
If j >= 0 Then
arr(i + 1, j) = IIf(arr(i + 1, j) = "", idVal, arr(i + 1, j) & ";" & idVal)
Else
ReDim Preserve arr(1 To 5, 1 To UBound(arr, 2) + 1)
arr(1, UBound(arr, 2)) = district
arr(i + 1, UBound(arr, 2)) = idVal
End If
Next x
Set outputRange = Range("E1")
outputRange.Resize(UBound(arr, 2), UBound(arr, 1)).Value = Application.Transpose(arr)
outputRange.Sort Key1:=Range("E1"), Header:=xlYes, Order1:=xlAscending
Application.ScreenUpdating = True
End Sub
Public Function inArray(arr As Variant, k As String, Optional rowNum As Long, Optional colNum As Long) As Long
Dim i As Long, j As Long
inArray = -1
If rowNum Then
For i = LBound(arr, 2) To UBound(arr, 2)
If arr(rowNum, i) = k Then
inArray = i
Exit Function
End If
Next i
Else
For i = LBound(arr, 1) To UBound(arr, 1)
If arr(i, colNum) = k Then
inArray = i
Exit Function
End If
Next i
End If
End Function
by the way, i've found another solution, usinf both dictionary and 3-dimension array.
Sub test()
Dim Blg As New Scripting.Dictionary
Dim Sgm As New Scripting.Dictionary
Dim Siciller() As String
ReDim Siciller(0 To 23, 0 To 3, 0 To 5)
Set alanBolge = range(range("a2"), range("a2").End(xlDown))
Set alanSegment = range(range("c2"), range("c2").End(xlDown))
i = 0
For Each d In alanBolge
If Not Blg.Exists(d.Value) Then
Blg.Add Key:=d.Value, item:=i
i = i + 1
End If
Next d
k = 0
For Each d In alanSegment
If Not Sgm.Exists(d.Value) Then
Sgm.Add Key:=d.Value, item:=k
k = k + 1
End If
Next d
'data reading
For Each d In alanBolge
Siciller(Blg(d.Value), Sgm(d.Offset(0, 2).Value), dolusay(Siciller, Blg(d.Value), Sgm(d.Offset(0, 2).Value)) + 1) = d.Offset(0, 1).Value
Next d
'output
For x = 1 To 4
For y = 1 To 24
Set h = Cells(1 + y, 5 + x)
h.Select
h.Value = sonucgetir(Siciller, Blg(h.Offset(0, -x).Value), Sgm(h.Offset(-y, 0).Value))
Next y
Next x
End Sub
Public Function dolusay(ByVal data As Variant, ByVal i1 As Integer, ByVal i2 As Integer) As Integer
Dim count As Integer
count = 0
For j = 0 To UBound(data, 3) - 1
If Len(data(i1, i2, j)) > 0 Then
count = count + 1
End If
Next
dolusay = count
End Function
Public Function sonucgetir(ByVal data As Variant, ByVal i1 As Integer, ByVal i2 As Integer) As String
sonucgetir = ""
For i = 0 To UBound(data, 3)
If Len(data(i1, i2, i)) > 0 Then
x = data(i1, i2, i) & ";" & x
sonucgetir = Left(x, Len(x) - 1)
End If
Next i
End Function
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
I have the following code below,
I want to get the entire row not just column 1 of the original array, how would i do this?
Sub Example1()
Dim arrValues() As Variant
Dim lastRow As Long
Dim filteredArray()
Dim lRow As Long
Dim lCount As Long
Dim tempArray()
lastRow = Sheets("Raw Data").UsedRange.Rows(Sheets("Raw Data").UsedRange.Rows.Count).Row
arrValues = Sheets("Raw Data").Range(Cells(2, 1), Cells(lastRow, 21)).Value
' First use a temporary array with just one dimension
ReDim tempArray(1 To UBound(arrValues))
For lCount = 1 To UBound(arrValues)
If arrValues(lCount, 3) = "phone" Then
lRow = lRow + 1
tempArray(lRow) = arrValues(lCount, 1)
End If
Next
' Now we know how large the filteredArray needs to be: copy the found values into it
ReDim filteredArray(1 To lRow, 1 To 1)
For lCount = 1 To lRow
filteredArray(lCount, 1) = tempArray(lCount)
Next
Sheets("L").Range("A2:U" & 1 + lRow) = filteredArray
End Sub
The ReDim statement can add records on-the-fly with the PRESERVE parameter but only into the last rank. This is a problem as the second rank of a two dimensioned array is typically considered the 'columns' while the first are the 'rows'.
The Application.Transpose can flip rows into columns and vise-versa but it has limitations. (see here and here)
A simple function to transpose without these limitations is actually very easy to build. All you really need are two arrays and two nested loops to flip them.
Sub Example1()
Dim arrVALs() As Variant, arrPHONs() As Variant
Dim v As Long, w As Long
With Sheets("Raw Data").Cells(1, 1).CurrentRegion
With .Resize(.Rows.Count - 1, 21).Offset(1, 0)
arrVALs = .Cells.Value
'array dimension check
'Debug.Print LBound(arrVALs, 1) & ":" & UBound(arrVALs, 1)
'Debug.Print LBound(arrVALs, 2) & ":" & UBound(arrVALs, 2)
'Debug.Print Application.CountIf(.Columns(3), "phone") & " phones"
End With
End With
ReDim arrPHONs(1 To UBound(arrVALs, 2), 1 To 1)
For v = LBound(arrVALs, 1) To UBound(arrVALs, 1)
If LCase(arrVALs(v, 3)) = "phone" Then
For w = LBound(arrVALs, 2) To UBound(arrVALs, 2)
arrPHONs(w, UBound(arrPHONs, 2)) = arrVALs(v, w)
Next w
ReDim Preserve arrPHONs(1 To UBound(arrPHONs, 1), _
1 To UBound(arrPHONs, 2) + 1)
End If
Next v
'there is 1 too many in the filtered array
ReDim Preserve arrPHONs(1 To UBound(arrPHONs, 1), _
1 To UBound(arrPHONs, 2) - 1)
'array dimension check
'Debug.Print LBound(arrPHONs, 1) & ":" & UBound(arrPHONs, 1)
'Debug.Print LBound(arrPHONs, 2) & ":" & UBound(arrPHONs, 2)
'Option 1: use built-in Transpose
'Worksheets("L").Range("A2:U" & UBound(arrPHONs, 2) + 1) = Application.Transpose(arrPHONs)
'Option 2: use custom my_2D_Transpose
Worksheets("L").Range("A2:U" & UBound(arrPHONs, 2) + 1) = my_2D_Transpose(arrPHONs)
End Sub
Function my_2D_Transpose(arr As Variant)
Dim a As Long, b As Long, tmp() As Variant
ReDim tmp(1 To UBound(arr, 2), 1 To UBound(arr, 1))
For a = LBound(arr, 1) To UBound(arr, 1)
For b = LBound(arr, 2) To UBound(arr, 2)
tmp(b, a) = Trim(arr(a, b))
Next b
Next a
my_2D_Transpose = tmp
End Function
So if you are in a hurry and the scope of your arrays is such that you will never reach the limits of Application.Transpose then by all means use it. If you cannot safely use transpose then use a custom function.