I have a function Sub fRemoveCharList(ColArray As Variant, char As Variant) (code below) to remove a list of characters w.r.t a list of header names.
If I call it with...
Sub RemoveCharList()
fRemoveCharList Array("field1","field2","field3"), Array("]", "&", "%")
End Sub
...it works fine
But if I instead go...
Call fRemoveCharList(("field1","field2","field3"), ("]","&","%"))
...which is my preferred way, I get a "Type mismatch" error. Do I need to have an array of arrays to use it like this?
I have Googled how to proceed, but found nothing I could work with.
The function:
Sub fRemoveCharList(ColArray As Variant, char As Variant)
Dim x As Variant
Dim LR As Long, i As Long, j As Long
Dim Heading As Variant
Dim headingFound As Range
Dim lngColIndex As Long
For Each Heading In ColArray
On Error Resume Next
Set headingFound = Range("1:1").Find(What:=Heading, LookIn:=xlFormulas, LookAt:=xlPart)
Err.Clear: On Error GoTo 0: On Error GoTo -1
If Not headingFound Is Nothing Then lngColIndex = headingFound.Column
LR = Cells(Rows.Count, lngColIndex).End(xlUp).Row
For i = 1 To LR
With Cells(i, lngColIndex)
x = .Value
For j = LBound(char) To UBound(char)
x = Replace(x, char(j), vbNullString)
Next
.Value = x
End With
Next i
Next
End Sub
Try either of:
Run fRemoveCharList Array("field1","field2","field3"), Array("]", "&", "%")
Or:
Call fRemoveCharList(Array("field1","field2","field3"), Array("]","&","%"))
Related
I have 2 arrays taken from 2 ranges in a sheet. I'm trying to create a third array that contains only the values contained in array 1 that are missing in array 2 (I found this code online).
Array 2´s size will vary and depends on this code:
Dim iListaIncompleta() As Variant
Dim iCountLI As Long
Dim iElementLI As Long
iCountLI = Range("B1").End(xlDown).Row
ReDim iListaIncompleta(iCountLI)
For iElementLI = 1 To iCountLI
iListaIncompleta(iElementLI - 1) = Cells(iElementLI, 2).Value
Next iElementLI
and Array 1's size is always from A1:A7, and I use this code to create it:
Dim iListaCompleta() As Variant
Dim iElementLC As Long
iListaCompleta = Range("A1:A7")
This is the original code I found online to extract missing values:
Dim v1 As Variant, v2 As Variant, v3 As Variant
Dim coll As Collection
Dim i As Long
'Original Arrays from the code:
v1 = Array("Bob", "Alice", "Thor", "Anna") 'Complete list
v2 = Array("Bob", "Thor") 'Incomplete list
Set coll = New Collection
For i = LBound(v1) To UBound(v1)
If v1(i) <> 0 Then
coll.Add v1(i), v1(i) 'Does not add value if it's 0
End If
Next i
For i = LBound(v2) To UBound(v2)
On Error Resume Next
coll.Add v2(i), v2(i)
If Err.Number <> 0 Then
coll.Remove v2(i)
End If
If coll.Exists(v2(i)) Then
coll.Remove v2(i)
End If
On Error GoTo 0
Next i
ReDim v3(LBound(v1) To (coll.Count) - 1)
For i = LBound(v3) To UBound(v3)
v3(i) = coll(i + 1) 'Collections are 1-based
Debug.Print v3(i)
Next i
End Sub
However, this code has arrays defined like this:
v1 = Array("Bob", "Alice", "Thor", "Anna")
And the actual arrays I wanna use are defined differently (as you can see in the first two pieces of code). When I try to run the code with them, it displays
Error 9: Subscript out of range.
The code works well as it originally is, but when I try to use MY arrays, it's when I get this error.
Obviously, I've tried it changing the names of the variables (v1 and v2) to my own 2 arrays (iListaCompleta and iListaIncompleta), and still doesn't work.
Any ideas??
Thank you in advance!
Here's a function that can be used to compare arrays of any dimension size to pull out differences and put only the differences in a one-dimensional array:
Public Function ArrayDifference(ByVal arg_Array1 As Variant, ByVal arg_array2 As Variant) As Variant
If Not IsArray(arg_Array1) Or Not IsArray(arg_array2) Then Exit Function 'Arguments provided were not arrays
Dim vElement As Variant
Dim hDifference As Object: Set hDifference = CreateObject("Scripting.Dictionary")
For Each vElement In arg_Array1
If Not hDifference.exists(vElement) Then hDifference.Add vElement, vElement
Next vElement
For Each vElement In arg_array2
If hDifference.exists(vElement) Then
hDifference.Remove vElement
Else
hDifference.Add vElement, vElement
End If
Next vElement
ArrayDifference = hDifference.Keys
End Function
Here's how you would call the function to compare two different arrays. It also includes how to populate the initial arrays using your provided setup:
Sub arrays()
Dim ws As Worksheet: Set ws = ActiveWorkbook.ActiveSheet
Dim rList1 As Range: Set rList1 = ws.Range("A1", ws.Cells(ws.Rows.Count, "A").End(xlUp))
Dim rList2 As Range: Set rList2 = ws.Range("B1", ws.Cells(ws.Rows.Count, "B").End(xlUp))
Dim aList1 As Variant
If rList1.Cells.Count = 1 Then
ReDim aList1(1 To 1, 1 To 1)
aList1(1, 1) = rList1.Value
Else
aList1 = rList1.Value
End If
Dim aList2 As Variant
If rList2.Cells.Count = 1 Then
ReDim aList2(1 To 1, 1 To 1)
aList2(1, 1) = rList2.Value
Else
aList2 = rList2.Value
End If
Dim aList3 As Variant
aList3 = ArrayDifference(aList1, aList2)
MsgBox Join(aList3, Chr(10))
End Sub
My goal is to check in one column if each cell contains (besides other values) a letter from my array.
The cells look something like "123A".
My array contains values A, C, D, X, Y, Z.
Both just example values.
Note my if-statement should be true if the cell contains any of the letters, so for the example it should be true.
For the cell Value "123B" it should be false (no B in array).
I found a "IsinArray" Function that appears to be working but checks for specific values.
What I would need is closer to ---> "*" & IsinArray & "*"
The function I found looks like this:
Public Function IsInArray(stringToBeFound As String, arr As Variant) As Boolean
IsInArray = Not IsError(Application.Match(stringToBeFound, arr, 0))
End Function
Also my For statement to loop through the column is working (I'd say ^^)
I am also open to "creative" solutions if you have any ideas how to do it better.
Try,
Public Function IsInArray(stringToBeFound As String, arr As Variant) As Boolean
Dim s As String, i As Integer
Dim a As Variant
For i = 1 To Len(stringToBeFound)
s = Mid(stringToBeFound, i, 1)
For Each a In arr
If s = a Then
IsInArray = True
Exit Function
End If
Next a
Next i
End Function
You could swop it around
Option Explicit
Public Sub Test()
Dim testArray(), cellValue As String, rng As Range
Set rng = ThisWorkbook.Worksheets("Sheet1").Range("A1") '<== contains
testArray = Array("A", "C", "D", "X", "Y", "Z")
Debug.Print IsInArrayValue(testArray, rng)
End Sub
Public Function IsInArrayValue(ByVal testArray As Variant, ByVal rng As Range) As Variant
Dim i As Long, testString As String
testString = rng.Text
If rng.Cells.Count > 1 Then
IsInArrayValue = CVErr(xlErrNA)
Exit Function
End If
For i = LBound(testArray) To UBound(testArray)
If InStr(testString, testArray(i)) > 0 Then
IsInArrayValue = True
Exit Function
End If
Next
IsInArrayValue = False
End Function
If using as an UDF you could either pass the array in as shown above or if array doesn't change you could move into the function itself. Personally, I prefer passing the array as an argument to the function as more flexible. I can't work out where your row to copy is coming from. Your comment posted as an answer uses a j variable that doesn't appear to be involved in the shown loop and the row is copied from another sheet. So below will not work directly but gives you a framework.
Public Function IsInArrayValue(ByVal rng As Range) As Variant
Dim i As Long, testString As String, testArray()
testArray = Array("A", "C", "D", "X", "Y", "Z")
testString = rng.Text
If rng.Cells.Count > 1 Then
IsInArrayValue CVErr(xlErrNA)
Exit Function
End If
For i = LBound(testArray) To UBound(testArray)
If InStr(testString, testArray(i)) > 0 Then
IsInArrayValue = True
Exit Function
End If
Next
IsInArrayValue = False
End Function
Call:
The comment below is looks like a new question but you probably want something like:
Dim loopRange As Range, rng As Range
With ThisWorkbook.Worksheets("Filter")
Set loopRange = .Range(.Cells(1, VarNutzerSpalte), .Cells(VarAnzahlZeilen, VarNutzerSpalte))
End With
For Each rng In loopRange
If IsInArrayValue(ArrAuswahlNutzer, rng) Then
rng.EntireRow.Copy '<= use Union to gather range if all being pasted in a block somewhere
End If
Next
A union version might looks like:
Dim loopRange As Range, rng As Range, unionRng As Range
With ThisWorkbook.Worksheets("Filter")
Set loopRange = .Range(.Cells(1, VarNutzerSpalte), .Cells(VarAnzahlZeilen, VarNutzerSpalte))
End With
For Each rng In loopRange
If IsInArrayValue(ArrAuswahlNutzer, rng) Then
If Not unionRng Is Nothing Then
Set unionRng = Union(unionRng, rng)
End If
Set unionRng = rng '<= use Union to gather range if all being pasted in a block somewhere
End If
Next
If Not unionRng Is Nothing Then
unionRng.EntireRow.Copy 'destination for paste
End If
Sorry to answer my own question (corrections/feedback to this solution is welcome of course)
I tried it like this and i guess it should work (cant really test because other parts of my makro arent working)
It is kinda unecessary complicated and maybe slow but id say it could work:
For i = 1 To VarAnzahlZeilen
Set rng = Worksheets("Filter").Range(Cells(i, VarNutzerSpalte), Cells(i, VarNutzerSpalte))
If IsInArrayValue(ArrAuswahlNutzer, rng) Then
Worksheets("Import").Rows(j).Copy
Worksheets("Filter").Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).PasteSpecial xlPasteValues
End If
Next i
Uses this function by QHarr (with only the array name changed)
Public Function IsInArrayValue(ByVal testArray As Variant, ByVal rng As Range) As Variant
Dim i As Long, testString As String
testString = rng.Text
If rng.Cells.Count > 1 Then
IsInArrayValue = CVErr(xlErrNA)
Exit Function
End If
For i = LBound(testArray) To UBound(testArray)
If InStr(testString, testArray(i)) > 0 Then
IsInArrayValue = True
Exit Function
End If
Next
IsInArrayValue = False
End Function
Thanks alot # QHarr and also # Dy.Lee !
I have function that returns me list of current sheets:
Function getListOfSheetsW() As Variant
Dim i As Integer
Dim sheetNames() As Variant
ReDim sheetNames(1 To Sheets.Count)
For i = 1 To Sheets.Count
sheetNames(i) = Sheets(i).name
Next i
getListOfSheetsW = sheetNames
End Function
Then I have function which returns TRUE or FALSE depending on if needle is in haystack or not.
Function IsInArray2(ByVal needle As String, haystack() As String) As Boolean
Dim element As Variant
For Each element In haystack
If element = needle Then
IsInArray = True
Exit Function
End If
Next element
IsInArray = False
End Function
My goal is to create new subroutine which will first check if sheet with given name already exist and if not then create new one. I've tried following:
Sub CreateNewSheet(ByVal dstWSheetName As String)
Dim srcWSheetName As String
' Dim sheetNames() As String
Dim sheetNames() As Variant
sheetNames = getListOfSheetsW()
Dim sheetCount As Integer
If IsInArray2(dstWSheetName, sheetNames) Then
MsgBox "Sheet with following name: " & dstWSheetName & " already exists"
Else
srcWSheetName = ActiveSheet.name
sheetCount = Sheets.Count
' CREATE NEW SHEET
' Worksheets(dstWsheetName).Delete
Sheets.Add.name = dstWSheetName
' Q: why 6 instead of 5
' Worksheets("Test").Move after:=Worksheets("Sheet5")
Worksheets(dstWSheetName).Move After:=Worksheets(sheetCount + 1)
' SWITCH TO SRC SHEET
Worksheets(srcWSheetName).Activate
End If
End Sub
I'm calling it this way:
Sub CallCreateNewSheet()
Call CreateNewSheet("test")
End Sub
I guess the problem is with Dim sheetNames() As String or Dim sheetNames() As Variant.
When I use Dim sheetNames() As String I get
Run-time error '13': Type mismatch
When I use Dim sheetNames() As Variant I get:
Compile error: Type mismatch: array or user-defined type expected
I had similar problem before but defining sheetNames as array did not helped here. What is the problem and what does the two different errors mean?
You will avoid all these problems if you switch from typed arrays to variant-arrays.
In your first function, delete this line:
Dim sheetNames() As Variant
Change the definition line of your 2nd function from this:
Function IsInArray2(ByVal needle As String, haystack() As String) As Boolean
...to this:
Function IsInArray2(ByVal needle As String, haystack) As Boolean
In your sub, change this line:
Dim sheetNames() As Variant
...to this:
Dim sheetNames
How about a new script like:
Sub NewSheetByName(SName as String)
Dim oldSheet as Object
For Each oldSheed in ThisWorkbook.Sheets
if oldSheet.Name = Sname Then
MsgBox "Sheet with following name: " & SName & " already exists"
Exit Sub
End If
Next
oldSheet = ActiveSheet
Sheets.Add.Name = SName
ActiveSheet.Move , Worksheets(Sheets.Count)
oldSheet.Activate
End Sub
The variables has to be in sinc.
Declare the variable sheetNames in the same manner in both procedures:
Sub CreateNewSheet(ByVal dstWSheetName As String) and
Function getListOfSheetsW() As Variant
declare it as : Dim sheetNames() As String
Also note that the Function IsInArray2 always returns False.
To correct this replace IsInArray with IsInArray2 in the body of the function.
It's a good practice to always have the
Option Explicit
at the beginning of the modules.
However it'll save all the trouble to validate the existence of a worksheet, just to assign the target worksheet to a variable, it will give an error and the variable return nothing if the worksheet in not present. Try this:
Dim Wsh As Worksheet
On Error Resume Next
Set Wsh = Workbook(x).Worksheets("Test")
On Error GoTo 0
If Wsh Is Nothing Then Add Worksheet
I am creating a workbook that will copy and paste data from a source worksheet to multiple other worksheets depending upon values in a column. However, once I start the macro, Excel enters a not responding state. I am operating on anywhere from 4000 to 500,000 rows, but only 4 columns. When I only have ~4000 rows, it works pretty fast (3 seconds). When I have ~30,000 rows, Excel enters a not responding state for ~10 seconds, but then finishes. I didn't wait long enough for the 300,000 row test.
My thought process to do this would be to sort all of the data based upon the strings in column B, put all of column B (which contains the strings I am searching though) into an array, then pull all of the unique strings out into another array. For example, if column B held "Search" in rows 1-200, and "Create" in rows 201-500, the macro will search through the rows and the second array (lets call it Scenario) would end up holding two values, "Search" and "Create".
During the searching, I also created two parallel arrays that correspond with the Scenario array which would hold the beginning and ending rows for that scenario. After that, I would just loop through the values in the parallel arrays and copy/paste from the source worksheet to the other worksheets.
NOTE: The sort works fine
Is there a way to make this faster?
Here is the code:
Allocate Data
Sub AllocateData()
Dim scenarioRange As String 'To hold the composite range
Dim parallelScenarioName() As String 'Holds the unique scenario names
Dim parallelScenarioStart() As Long 'Holds the starting row of the scenario
Dim parallelScenarioEnd() As Long 'Holds the ending row of the scenario
Sheets("raw").Activate 'Raw is the source worksheet
'Populates the parallel scenario arrays
Call GetScenarioList(parallelScenarioName, parallelScenarioStart, parallelScenarioEnd)
'Loops through the scenario parallel array and coes the copy and paste to other worksheets
'Workseets are named the same as the scenarios
For intPosition = LBound(parallelScenarioName) To (UBound(parallelScenarioName) - 1)
scenarioRange = "A" & parallelScenarioStart(intPosition) & ":" & "D" & parallelScenarioEnd(intPosition)
Range(scenarioRange).Select
Selection.Copy
Worksheets(parallelScenarioName(intPosition)).Activate
Range("A1").Select
ActiveSheet.Paste
Sheets("raw").Activate
Next
End Sub
GetScenarioList
Sub GetScenarioList(ByRef parallelScenarioName() As String, ByRef parallelScenarioStart() As Long, ByRef parallelScenarioEnd() As Long)
Dim scenarioName As Variant
Dim TotalRows As Long
Dim arraySize As Long
arraySize = 1
'Prep the parallel array for scenario name with the first value
ReDim parallelScenarioStart(1)
ReDim parallelScenarioName(1)
parallelScenarioStart(0) = 1 'First spot on the scenario start will be row 1
'Prep the first scenario name
'Sometimes a number will be attached on the end of the scenario name delimited by a period. Ignore it.
If (InStr(Cells(1, 2).Text, ".") <> 0) Then
parallelScenarioName(0) = Left(Cells(1, 2).Text, InStr(Cells(1, 2).Text, ".") - 1)
Else
parallelScenarioName(0) = Cells(1, 2).Text
End If
'Get the total amount of rows
TotalRows = Rows(Rows.Count).End(xlUp).row
'Loop through all of the rows
For i = 1 To TotalRows
'Sometimes a number will be attached on the end of the scenario name delimited by a period. Ignore it.
If (InStr(Cells(i, 2).Text, ".") <> 0) Then
scenarioName = Left(Cells(i, 2).Text, InStr(Cells(i, 2).Text, ".") - 1)
Else
scenarioName = Cells(i, 2).Text
End If
'If the scenario name is not contained in the unique array
If IsNotInArray(scenarioName, parallelScenarioName) Then
Call AddScenarioEndRow(i, arraySize, parallelScenarioEnd)
Call AddNewScenarioToParallelArray(scenarioName, arraySize, parallelScenarioName)
Call AddNewScenarioStartRow(i, arraySize, parallelScenarioStart)
End If
Next
'Cleanup. The above code did not cover the ending row of the last scenario
Call AddScenarioEndRow(TotalRows + 1, arraySize, parallelScenarioEnd)
End Sub
IsNotInArray
Function IsNotInArray(stringToBeFound As Variant, ByRef parallelScenarioName() As String) As Boolean
IsNotInArray = Not (UBound(Filter(parallelScenarioName, stringToBeFound)) > -1)
End Function
Parallel Arrays
Sub AddNewScenarioToParallelArray(str As Variant, arraySize As Long, ByRef parallelScenarioName() As String)
arraySize = UBound(parallelScenarioName) + 1
ReDim Preserve parallelScenarioName(arraySize)
parallelScenarioName(arraySize - 1) = str
End Sub
Sub AddScenarioEndRow(row As Variant, ByRef arraySize As Long, ByRef parallelScenarioEnd() As Long)
ReDim Preserve parallelScenarioEnd(arraySize)
parallelScenarioEnd(arraySize - 1) = row - 1
End Sub
Sub AddNewScenarioStartRow(row As Variant, ByRef arraySize As Long, ByRef parallelScenarioStart() As Long)
ReDim Preserve parallelScenarioStart(arraySize)
parallelScenarioStart(arraySize - 1) = row
End Sub
This will work on unsorted data, but will be much faster if you sort first.
Sub AllocateData()
Dim shtRaw As Worksheet, currVal, rng As Range
Dim c As Range, rngCopy As Range, i As Long, tmp
Set shtRaw = Sheets("raw")
On Error GoTo haveError
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Set rng = shtRaw.Range(shtRaw.Range("B1"), _
shtRaw.Cells(Rows.Count, "B").End(xlUp))
currVal = "~~~~~~~~~~~~~~~" 'or any non-value
For Each c In rng.Cells
tmp = c.Value
If tmp <> currVal Then
If Not rngCopy Is Nothing Then
rngCopy.Copy Sheets(currVal).Cells(Rows.Count, _
"A").End(xlUp).Offset(1, 0)
End If
Set rngCopy = c.Offset(0, -1).Resize(1, 4)
currVal = tmp
i = 1
Else
i = i + 1
Set rngCopy = rngCopy.Resize(i, 4)
End If
Next c
If Not rng Is Nothing Then
rngCopy.Copy Sheets(currVal).Cells(Rows.Count, "A").End(xlUp).Offset(1, 0)
End If
haveError:
'must reset calculation, or it will remain on "manual"
Application.Calculation = xlCalculationAutomatic
'ScreenUpdating will auto-reset once the sub exits,
' but I think it's good practise to explicitly reset it
Application.ScreenUpdating = True
End Sub
Copy-paste is, in my expreience, the slowest thing you can do in VBA.
Try simply assigning the values of range 1 to range 2, kinda like this:
range("b1:b4").value=range("a1:a4").value
Make sure the ranges are of the same size.
In your AllocateData sub, you could use something like:
Worksheets(parallelScenarioName(intPosition)).activate
Range(cells(1,1),cells(scenariorange.rows.count,1).value=scenariorange.value
Sheets("raw").Activate
Oh, I have changed scenariorange to be a range variable, lot easier to use in my opinion. Use it like this:
Dim ScenarioRange as Range
Set ScenarioRange = Range("A" & parallelScenarioStart(intPosition) & ":" & "D" & parallelScenarioEnd(intPosition))
Hope this speeds things up. (And I hope you can understand what I'm trying to say here, I'm a bit sleepy... :) )
Also, turning off the screenupdating usually speeds up the program a lot.
application.screenupdating=false
Don't forget to turn it back on at the end of the code!
My requirements ended up changing slightly. The QA lead wanted Metadata in the raw worksheet, so I had the full list of scenarios at my disposal instead of having to look at every row in the raw data. As a result, I could save and sort the scenario list to an array, and then do a .Find(parallelScenarioName(intPosition + 1)).row to get the row of the next scenario.
Because of this change, I did not fully implement and test Tim Williams solution which would iterate through every row in the data. I have to move on for now, but will revisit and test Tim's solution for my own knowledge soon.
The finished code is below.
'This is in a module so that my subs can see it
Option Explicit
Public Const DATASOURCE_WORKSHEET As String = "raw"
'This is the macro is called. Can be considered main.
Sub AllocateImportedData()
Call SortDataSourceWorksheet
Call AllocateData
End Sub
Sub SortDataSourceWorksheet()
Dim entireRangeToSort As String
Dim colToSortUpon As String
Dim lastRow As Long
lastRow = FindLastRowOfRawData
entireRangeToSort = ConstructRangeString("A", 1, "D", lastRow)
colToSortUpon = ConstructRangeString("B", 1, "B", lastRow)
Call SortRangeByColumnAtoZ(entireRangeToSort, colToSortUpon)
End Sub
Sub SortRangeByColumnAtoZ(entireRangeToSort As String, colToSortUpon As String)
ActiveWorkbook.Worksheets(DATASOURCE_WORKSHEET).Sort.SortFields.Clear
ActiveWorkbook.Worksheets(DATASOURCE_WORKSHEET).Sort.SortFields.Add Key:=Range(colToSortUpon), _
SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
With ActiveWorkbook.Worksheets(DATASOURCE_WORKSHEET).Sort
.SetRange Range(entireRangeToSort)
.Header = xlGuess
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
End Sub
Sub AllocateData()
Dim scenarioRange As String 'To hold the composite range
Dim parallelScenarioName() As String 'Holds the unique scenario names
Dim parallelScenarioStart() As Long 'Holds the starting row of the scenario
Dim parallelScenarioEnd() As Long 'Holds the ending row of the scenario
Sheets(DATASOURCE_WORKSHEET).Activate
Call PopulateParallelScenarioArrays(parallelScenarioName, parallelScenarioStart, parallelScenarioEnd)
Call PerformAllocation(parallelScenarioName, parallelScenarioStart, parallelScenarioEnd)
Call FinishByActivatingDesiredWorksheet(DATASOURCE_WORKSHEET)
End Sub
Sub PerformAllocation(ByRef parallelScenarioName() As String, ByRef parallelScenarioStart() As Long, ByRef parallelScenarioEnd() As Long)
For intPosition = LBound(parallelScenarioName) To (UBound(parallelScenarioName) - 1)
scenarioRange = ConstructRangeString("A", parallelScenarioStart(intPosition), "D", parallelScenarioEnd(intPosition))
Range(scenarioRange).Select
Selection.Copy
Worksheets(parallelScenarioName(intPosition)).Activate
Range("A1").Select
ActiveSheet.Paste
Sheets(DATASOURCE_WORKSHEET).Activate
Next
End Sub
Sub PopulateParallelScenarioArrays(ByRef parallelScenarioName() As String, ByRef parallelScenarioStart() As Long, ByRef parallelScenarioEnd() As Long)
Dim numberOfScenarios As Long
numberOfScenarios = GetScenarioListFromRaw(parallelScenarioName)
ReDim parallelScenarioStart(numberOfScenarios)
ReDim parallelScenarioEnd(numberOfScenarios)
Call GetStartAndEndRows(parallelScenarioName, parallelScenarioStart, parallelScenarioEnd)
End Sub
Function GetScenarioListFromRaw(ByRef parallelScenarioName() As String) As Long
Dim numberOfScenarios As Long
Dim scenarioRange As String
Const scenarioListStartColumn As String = "F"
Const scenarioListStartRow As Long = "3"
numberOfScenarios = GetNumberOfScenarios(scenarioListStartColumn, scenarioListStartRow)
ReDim parallelScenarioName(numberOfScenarios)
'Populate parallel scenario name
For i = 0 To (numberOfScenarios - 1)
scenarioRange = scenarioListStartColumn & (scenarioListStartRow + i)
parallelScenarioName(i) = Range(scenarioRange).Text
Next
Call AtoZBubbleSort(parallelScenarioName)
GetScenarioListFromRaw = numberOfScenarios
End Function
Function GetNumberOfScenarios(scenarioListStartColumn As String, scenarioListStartRow As Long)
GetNumberOfScenarios = Range(scenarioListStartColumn & scenarioListStartRow, Range(scenarioListStartColumn & scenarioListStartRow).End(xlDown)).Rows.Count
End Function
Sub GetStartAndEndRows(ByRef parallelScenarioName() As String, ByRef parallelScenarioStart() As Long, ByRef parallelScenarioEnd() As Long)
Dim TotalRows As Long
Dim newScenarioRow As Long
'Prep the parallel array for scenario name with the first value
parallelScenarioStart(0) = 1 'First spot on the scenario start will be row 1
'Get the total amount of rows
TotalRows = Rows(Rows.Count).End(xlUp).row
For intPosition = LBound(parallelScenarioName) To (UBound(parallelScenarioName) - 1)
'Find the row of the next scenario
newScenarioRow = Worksheets(DATASOURCE_WORKSHEET).Columns(2).Find(parallelScenarioName(intPosition + 1)).row
'Next scenario row - 1 is going to be the end of the current row
parallelScenarioEnd(intPosition) = newScenarioRow - 1
'Set starting row of next scenario
parallelScenarioStart(intPosition + 1) = newScenarioRow
Next
End Sub
Sub FinishByActivatingDesiredWorksheet(desiredWorksheet As String)
Sheets(desiredWorksheet).Activate
Range("A1").Select
End Sub
Sub AtoZBubbleSort(ByRef parallelScenarioName() As String)
Dim s1 As String, s2 As String
Dim i As Long, j As Long
For i = LBound(parallelScenarioName) To UBound(parallelScenarioName)
For j = i To UBound(parallelScenarioName)
If UCase(parallelScenarioName(j)) < UCase(parallelScenarioName(i)) Then
s1 = parallelScenarioName(j)
s2 = parallelScenarioName(i)
parallelScenarioName(i) = s2
parallelScenarioName(j) = s1
End If
Next
Next
End Sub
Sub ClearWorkbookCells()
Dim anyWS As Worksheet
For Each anyWS In ThisWorkbook.Worksheets
Call ClearWorksheetCells(anyWS)
Next
End Sub
Sub ClearWorksheetCells(ws As Worksheet)
ws.Activate
' Find the last row and create range var
lastRow = FindLastRowOfRawData
ClearRange = "A1:" & "D" & lastRow
'Select the area to clear and perform clear
ActiveSheet.Range(ClearRange).Select
Selection.ClearContents
End Sub
Function FindLastRowOfRawData()
FindLastRowOfRawData = Range("A1").End(xlDown).row
End Function
Function ConstructRangeString(startCol As String, startRow As Long, endCol As String, endRow As Long) As String
ConstructRangeString = startCol & startRow & ":" & endCol & endRow
End Function
how do i filter an array using another array vb6
Edit
given an array A, remove all elements in array B from array A
In that case, I'd just sort one array, then iterate through the second, deleting things from the first array if they are found. This algorithm seems to take O(n lg n) and does what you want it to do.
Assuming they are integer arrays:
Dim FilteredArray() As Integer
Dim X as Long
Dim Y as Long
Dim Z as Long
Dim bDupe as Boolean
Z = -1
For X = 0 to UBound(A)
bDupe = False
For Y = 0 to UBound(B)
If A(X) = B(Y) Then
bDupe = True
Exit For
End If
Next
If Not bDupe Then
Z = Z + 1
ReDim Preserve FilteredArray(Z)
FilteredArray(Z) = A(X)
End If
Next
Try something like this
Option Explicit
Private Sub Form_Load()
Dim vElem As Variant
For Each vElem In SubstractArray(Array("aa", "b", "test"), Array("c", "aa", "test"))
Debug.Print vElem
Next
End Sub
Private Function SubstractArray(arrSrc As Variant, arrBy As Variant) As Variant
Dim cIndex As Collection
Dim vElem As Variant
Dim vRetVal As Variant
Dim lIdx As Long
If UBound(arrSrc) < LBound(arrSrc) Then
Exit Function
End If
'--- build index collection
Set cIndex = New Collection
For Each vElem In arrBy
cIndex.Add vElem, "#" & vElem
Next
'--- allocate output array
lIdx = LBound(arrSrc)
ReDim vRetVal(lIdx To UBound(arrSrc)) As Variant
'--- iterate source and seek in index
For Each vElem In arrSrc
On Error Resume Next
IsObject cIndex("#" & vElem)
If Err.Number <> 0 Then
vRetVal(lIdx) = vElem
lIdx = lIdx + 1
End If
On Error GoTo 0
Next
'--- shrink output array
If lIdx = LBound(vRetVal) Then
vRetVal = Split(vbNullString)
Else
ReDim Preserve vRetVal(0 To lIdx - 1) As Variant
End If
SubstractArray = vRetVal
End Function
i have found the answer myself, thanks for all who contributed
Function FilterArray(ByVal Source As String, ByVal Search As String, Optional _
ByVal Keep As Boolean = True) As String
Dim i As Long
Dim SearchArray() As String
Dim iSearchLower As Long
Dim iSearchUpper As Long
If LenB(Source) <> 0 And LenB(Search) <> 0 Then
SearchArray = Split(Search, " ")
Else
FilterArray = Source
Exit Function
End If
iSearchLower = LBound(SearchArray)
iSearchUpper = UBound(SearchArray)
For i = iSearchLower To iSearchUpper
DoEvents
Source = Join(Filter(Split(Source, " "), SearchArray(i), Keep, _
vbTextCompare), " ")
Next i
FilterArray = Source
End Function