I currently have two if then VBA codes, that are running extremely slow for my large data set and am looking for ways to optimize and speed them up.
The first formula is looking in a range of cells in column J that have a value in column A, and if they are blank in J then entering in a formula that contains a user defined function.
The second code is looking to see if any of the values in column J end in a , and if they do then remove that comma. Any help would be greatly appreciated!
Sub FillEmpty()
Dim r As Range, LastRow As Long
LastRow = Cells(Rows.Count, 1).End(xlUp).row
For Each r In Range("J2:J" & LastRow)
If r.Text = "" Then r.FormulaR1C1 = _
"=IFERROR((IF(LEFT(RC[-9],6)=""master"", get_areas(RC[-7]), """")),"""")"
Next r
End Sub
Sub NoComma()
Dim c As Range
For Each c In Range("J:J")
With c
If Right(.Value, 1) = "," Then .Value = Left(.Value, Len(.Value) - 1)
End With
Next c
End Sub
Speedup: Arrays
1. Code
It is unbelievable that you do not need formulaR1C1 to get a formula into the range when pasting from the array into range. But it's working on my computer. To conclude, the same principle from the second code is applied on the first: Range into Array, Loop and Array into Range. It doesn't get faster than this. The other idea for the first code was to create a range union and then paste the formula in one go.
Sub FillEmpty()
Const cCol As Variant = "J" ' Column Letter/Number
Const cFirst As Long = 2 ' First Row
Dim vntFE As Variant ' Range Array
Dim i As Long ' Range Array Rows Counter
' Paste range into array.
vntFE = Cells(cFirst, cCol).Resize(Cells(Rows.Count, cCol) _
.End(xlUp).Row - cFirst + 1)
' Loop through array and perform calculation.
For i = 1 To UBound(vntFE)
If vntFE(i, 1) = "" Then vntFE(i, 1) = "=IFERROR((IF(LEFT(RC[-9],6)" _
& "=""master"", get_areas(RC[-7]), """")),"""")"
Next
' Paste array into range.
Cells(cFirst, cCol).Resize(Cells(Rows.Count, cCol) _
.End(xlUp).Row - cFirst + 1) = vntFE
End Sub
Sub FillEmptyEasy()
Const cCol As Variant = "J" ' Column Letter/Number
Const cFirst As Long = 2 ' First Row
Dim rng As Range ' Range
Dim vntFE As Variant ' Range Array
Dim LastRow As Long ' Last Row
Dim i As Long ' Range Array Rows Counter
' Calculate Last Row.
LastRow = Cells(Rows.Count, cCol).End(xlUp).Row
' Calculate Range.
Set rng = Cells(cFirst, cCol).Resize(LastRow - cFirst + 1)
' Paste range into array.
vntFE = rng
' Loop through array and perform calculation.
For i = 1 To UBound(vntFE)
If vntFE(i, 1) = "" Then vntFE(i, 1) = "=IFERROR((IF(LEFT(RC[-9],6)" _
& "=""master"", get_areas(RC[-7]), """")),"""")"
Next
' Paste array into range.
rng = vntFE
End Sub
2. Code
Sub NoComma()
Const cCol As Variant = "J" ' Column Letter/Number
Const cFirst As Long = 2 ' First Row
Dim vntNoC As Variant ' Range Array
Dim i As Long ' Range Array Rows Counter
' Paste range into array.
vntNoC = Cells(cFirst, cCol).Resize(Cells(Rows.Count, cCol) _
.End(xlUp).Row - cFirst + 1)
' Loop through array and perform calculation.
For i = 1 To UBound(vntNoC)
If Right(vntNoC(i, 1), 1) = "," Then _
vntNoC(i, 1) = Left(vntNoC(i, 1), Len(vntNoC(i, 1)) - 1)
Next
' Paste array into range.
Cells(cFirst, cCol).Resize(Cells(Rows.Count, cCol) _
.End(xlUp).Row - cFirst + 1) = vntNoC
End Sub
Sub NoCommaEasy()
Const cCol As Variant = "J" ' Column Letter/Number
Const cFirst As Long = 2 ' First Row
Dim rng As Range ' Range
Dim vntNoC As Variant ' Range Array
Dim lastrow As Long ' Last Row
Dim i As Long ' Range Array Rows Counter
' Calculate Last Row.
lastrow = Cells(Rows.Count, cCol).End(xlUp).Row
' Calculate Range.
Set rng = Cells(cFirst, cCol).Resize(lastrow - cFirst + 1)
' Paste range into array.
vntNoC = rng
' Loop through array and perform calculation.
For i = 1 To UBound(vntNoC)
If Right(vntNoC(i, 1), 1) = "," Then _
vntNoC(i, 1) = Left(vntNoC(i, 1), Len(vntNoC(i, 1)) - 1)
Next
' Paste array into range.
rng = vntNoC
End Sub
Related
Sub add_number()
Dim a As Currency
Dim i As Integer
lastrow = ActiveSheet.Cells(Rows.Count, 7).End(xlUp).Row
a = 0
For i = lastrow To Range("g4").Offset(1, 0) Step by - 1
a = a + ActiveSheet.Cells(i, 7).Value
Next
ActiveSheet.Cells(h1).Value = a
End Sub
Sum Up Filtered Column
In Excel, you could use the SUBTOTAL function.
In VBA, you could avoid a loop and just evaluate a formula or write a formula to the cell as illustrated in the following code.
Option Explicit
Sub SumFilteredColumn()
Const dRow As Long = 1 ' worksheet row
Const sCol As Long = 7 ' n-th column of the range (table)
Dim ws As Worksheet: Set ws = ActiveSheet ' improve!
' Restrict to continue only if the auto filter is turned on.
If Not ws.AutoFilterMode Then Exit Sub
' Reference the data column range.
Dim scrg As Range
With ws.AutoFilter.Range.Columns(sCol)
Set scrg = .Resize(.Rows.Count - 1).Offset(1)
End With
Dim dCol As Long: dCol = scrg.Column ' n-th column of the worksheet
' Write the sum (subtotal).
With ws.Cells(dRow, dCol)
' Write the value.
.Value = ws.Evaluate("SUBTOTAL(109," & scrg.Address & ")")
' Maybe writing a formula makes more sense.
'.Formula = "=SUBTOTAL(109," & scrg.Address(, 0) & ")"
End With
End Sub
I am trying to change the value of each cell in column 7 that meets criteria. So far I managed to change the value with one criteria but I would like to add up to 14 criteria. Thanks for your help
Sub ChangeValue()
Dim i As Integer
Dim WK As Worksheet
Dim rg1 As range
Dim rg2 As range
Set WK = Sheet4
Set rg1 = range("AB2")
Set rg2 = range("AB3")
For i = Cells(Rows.Count, 7).End(xlUp).Row To 1 Step -1
If Cells(i, 7).Value = rg1 Then
Cells(i, 7).Value = rg2.Value
End If
Next i
End Sub
I would like to have more conditions something like if = AB3 change to AB4 if= AB4 Change to AB5 and so on...
To create a variable list of value/replace value pairs I would suggest using a dictionary:
Option Explicit
Sub ChangeValue()
Dim d
Set d = CreateObject("Scripting.Dictionary")
Dim r_test_value As Range
Dim r_anchor As Range
Set r_anchor = Range("AB2")
'need at least 2 values
If Not IsEmpty(r_anchor) And Not IsEmpty(r_anchor.Offset(1, 0)) Then
Set r_test_value = Range(r_anchor, _
Cells(Rows.Count, r_anchor.Column).End(xlUp).Offset(-1, 0))
Debug.Print r_test_value.Address
Dim i As Long
i = 0
Dim r As Range
For Each r In r_test_value
d.Add r.Value, r.Offset(i+1, 0).Value
i = i + 1
Next r
For i = Cells(Rows.Count, 7).End(xlUp).Row To 1 Step -1
If d.exists(Cells(i, 7).Value) Then
Cells(i, 7).Value = d.Item(Cells(i, 7).Value)
End If
Next i
End If
End Sub
Search and Replace Cell Values
EDIT
This is a more appropriate solution.
Adjust the starting rows i.e. For i = ? and For k = ?
Second Answer
Sub replaceValues()
' Determine Source Last Row.
Dim sLastRow As Long
sLastRow = Sheet4.Cells(Sheet4.Rows.Count, "AB").End(xlUp).Row
' Determine Destination Last Row.
Dim dLastRow As Long
dLastRow = Sheet4.Cells(Sheet4.Rows.Count, "G").End(xlUp).Row
Dim i As Long ' Destination Range Rows Counter
Dim k As Long ' Source Rows Counter
' Loop through rows of Destination Range.
For i = 2 To dLastRow
' Loop through rows of Source Range.
For k = 1 To sLastRow - 1
' When a value is found...
If Sheet4.Cells(i, "G").Value = Sheet4.Cells(k, "AB").Value Then
' ... replace it with the value below.
Sheet4.Cells(i, "G").Value = Sheet4.Cells(k + 1, "AB").Value
Exit For ' Value has been found and replaced. Stop searching.
' Otherwise you'll end up with the last replace value.
End If
Next k
Next i
' Inform.
MsgBox "Values replaced.", vbInformation, "Success"
End Sub
The First Answer (misunderstood)
The first solution is for using worksheet code names. It can be used for two worksheets. It is one in your case (Sheet4).
The second solution shows how to use it in two worksheets using worksheet names.
The code will loop through a column range of values and replace each value found in a row range of 'search values' with an associated 'replace value' in another same sized row range (in this case the ranges are adjacent, one below the other).
The Code
Option Explicit
Sub replaceValuesWorksheetCodeNames()
' Source
' Make sure the following two are of the same size.
Const srcAddress As String = "AB2:AO2"
Const rplAddress As String = "AB3:AO3"
' Destination
Const dFirstCell As String = "G2"
' Write Source Row Ranges to Source Arrays (Search and Replace).
With Sheet4
Dim srcData As Variant: srcData = .Range(srcAddress).Value
Dim rplData As Variant: rplData = .Range(rplAddress).Value
End With
' Define Destination Column Range.
Dim rg As Range
Dim RowOffset As Long
With Sheet4.Range(dFirstCell)
RowOffset = .Row - 1
Set rg = .Resize(.Worksheet.Rows.Count - RowOffset) _
.Find("*", , xlFormulas, , , xlPrevious)
If rg Is Nothing Then Exit Sub
Set rg = .Resize(rg.Row - RowOffset)
End With
' Write values from Destination Column Range to Data Array.
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 = rg.Value
End If
' Search and replace values in Data Array.
Dim cValue As Variant
Dim cIndex As Variant
Dim i As Long
For i = 1 To rCount
cValue = Data(i, 1)
If Not IsError(cValue) Then
If Len(cValue) > 0 Then
cIndex = Application.Match(cValue, srcData, 0)
If IsNumeric(cIndex) Then
' When the replace data is in a row range.
Data(i, 1) = rplData(1, cIndex)
' When the replace data is in a column range.
'Data(i, 1) = rplData(cIndex, 1)
End If
End If
End If
Next i
' Write possibly modified values from Data Array back
' to Destination Column Range.
rg.Value = Data
' Inform.
MsgBox "Values replaced.", vbInformation, "Success"
End Sub
Sub replaceValuesWorksheetNames()
' Source
Const sName As String = "Sheet1"
' Make sure the following two are of the same size.
Const srcAddress As String = "AB2:AO2"
Const rplAddress As String = "AB3:AO3"
' Destination
Const dName As String = "Sheet2"
Const dFirstCell As String = "G2"
' Workbook
Dim wb As Workbook: Set wb = ThisWorkbook
' Write Source Row Ranges to Source Arrays (Search and Replace).
With wb.Worksheets(sName)
Dim srcData As Variant: srcData = .Range(srcAddress).Value
Dim rplData As Variant: rplData = .Range(rplAddress).Value
End With
' Define Destination Column Range.
Dim rg As Range
Dim RowOffset As Long
With wb.Worksheets(dName).Range(dFirstCell)
RowOffset = .Row - 1
Set rg = .Resize(.Worksheet.Rows.Count - RowOffset) _
.Find("*", , xlFormulas, , , xlPrevious)
If rg Is Nothing Then Exit Sub
Set rg = .Resize(rg.Row - RowOffset)
End With
' Write values from Destination Column Range to Data Array.
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 = rg.Value
End If
' Search and replace values in Data Array.
Dim cValue As Variant
Dim cIndex As Variant
Dim i As Long
For i = 1 To rCount
cValue = Data(i, 1)
If Not IsError(cValue) Then
If Len(cValue) > 0 Then
cIndex = Application.Match(cValue, srcData, 0)
If IsNumeric(cIndex) Then
' When the replace data is in a row range.
Data(i, 1) = rplData(1, cIndex)
' When the replace data is in a column range.
'Data(i, 1) = rplData(cIndex, 1)
End If
End If
End If
Next i
' Write possibly modified values from Data Array back
' to Destination Column Range.
rg.Value = Data
' Inform.
MsgBox "Values replaced.", vbInformation, "Success"
End Sub
My code blow, was made for only 3 years, (2016, 2017 & 2018). but now i have added 4 more years, but i dont know how to fit the description, so that i adds 4 more classes and four more on row Q Ark1. So that it fits with years 2016 to 2022. The code is added below, it transposes the information from Ark2 to Ark1.
I really hope you can help.
Sub TransposeAH()
Const cSheet1 As Variant = "Ark2" ' Sheet1 Name/Index
Const cSheet2 As Variant = "Ark1" ' Sheet2 Name/Index
Const cFirst As Integer = 23 ' First Row Number
Const cCol1First As Variant = "A" ' Range1 First Column Letter/Number
Const cCol1Last As Variant = "C" ' Range1 Last Column Letter/Number
Const cCol2First As Variant = "E" ' Range2 First Column Letter/Number
Const cCol2Last As Variant = "G" ' Range2 Last Column Letter/Number
Const cColumns As Integer = 1 ' Number of New Columns
Const cFirstCell As String = "N1" ' Target Range First Cell Address
Dim vntH As Variant ' Range2 Headers
Dim vnt2 As Variant ' Range2 Array
Dim vnt3 As Variant ' Range1 Temp Array (if value is "")
Dim vnt1 As Variant ' Range1 Array
Dim vntT As Variant ' Target Array
Dim LastUR As Long ' Last Used Row
Dim i As Long ' Arrays Row Counter
Dim j As Integer ' Arrays Column Counter
Dim k As Long ' Target Array Rows Counter
Dim m As Integer ' Range1 Temp Array Column Counter
' From Sheet1 to Arrays.
With Worksheets(cSheet1)
' Calculate Last Used Row.
With .Range(.Cells(cFirst, cCol1First), .Cells(.Rows.Count, cCol2Last))
If .Find("*", .Cells(.Rows.Count, .Columns.Count), -4123, , 1) _
Is Nothing Then Exit Sub
LastUR = .Find("*", , , , , 2).Row
End With
' Paste ranges into arrays.
vnt1 = .Range(.Cells(cFirst, cCol1First), .Cells(LastUR, cCol1Last))
vnt2 = .Range(.Cells(cFirst, cCol2First), .Cells(LastUR, cCol2Last))
vntH = .Range(.Cells(cFirst - 1, cCol2First), _
.Cells(cFirst - 1, cCol2Last))
End With
' Resize Target Array.
ReDim vntT(1 To UBound(vnt2) * UBound(vnt2, 2), _
1 To cColumns + UBound(vnt1, 2))
' Write Range2 Array to Target Array.
For i = 1 To UBound(vnt2)
For j = 1 To UBound(vnt2, 2)
k = k + 1
vntT(k, 1) = vntH(1, j)
vntT(k, 2) = vnt2(i, j)
Next
Next
' Resize Range1 Temp Array (if value is "")
ReDim vnt3(1 To 1, 1 To UBound(vnt1, 2))
' Copy first line of Range1 Array to Range1 Temp Array.
For m = 1 To UBound(vnt3, 2)
vnt3(1, m) = vnt1(1, m)
Next
' Write Range1 Array to Target Array.
k = 0
For i = 1 To UBound(vnt1)
For j = 1 To UBound(vnt1, 2)
k = k + 1
For m = 1 To UBound(vnt2, 2)
If vnt1(i, m) <> "" Then
If vnt1(i, m) <> vnt3(1, m) Then
vnt3(1, m) = vnt1(i, m)
End If
End If
vntT(k, m + cColumns) = vnt3(1, m)
Next
Next
Next
' Paste Target Array into Target Range resized
' from Target Range First Cell Address.
With Worksheets(cSheet2).Range(cFirstCell)
.Resize(UBound(vntT), UBound(vntT, 2)) = vntT
End With
End Sub
In the picture of the sheet I get my data from "Ark2" and the sheet I get the data to "Ark1". In Ark1 I want want to give an ID for the data. I show an example in yellow, grey, green and blue colours. I want the text ID to stand as it does in the example row "K".
the code is added at the end..
Sub MyProcedure()
a = Worksheets("ark1").Cells(Rows.Count, 1).End(xlUp).Row
MsgBox (a)
End Sub
Private Sub CommandButton1_Click()
Dim nøgletal As String, år As Integer
Worksheets("Ark2").Select
nøgletal = Range("B2")
år = Range("C2")
Worksheets("Ark1").Select
Worksheets("Ark1").Range("A4").Select
ThisWorkbook.Worksheets("Ark1").Range("A1:A100").Value = ThisWorkbook.Worksheets("Ark2").Range("A12:A100").Value
ThisWorkbook.Worksheets("Ark1").Range("B1:B100").Value = ThisWorkbook.Worksheets("Ark2").Range("B12:B100").Value
ThisWorkbook.Worksheets("Ark1").Range("C1:C100").Value = ThisWorkbook.Worksheets("Ark2").Range("C12:C100").Value
ThisWorkbook.Worksheets("Ark1").Range("E1:E100").Value = ThisWorkbook.Worksheets("Ark2").Range("E12:E100").Value
ThisWorkbook.Worksheets("Ark1").Range("G1:G100").Value = ThisWorkbook.Worksheets("Ark2").Range("M12:M100").Value
ThisWorkbook.Worksheets("Ark1").Range("F1:F100").Value = ThisWorkbook.Worksheets("Ark2").Range("N12:N100").Value
ThisWorkbook.Worksheets("Ark1").Range("H1:H100").Value = ThisWorkbook.Worksheets("Ark2").Range("O12:O100").Value
If Worksheets("Ark1").Range("A4").Offset(1, 0) <> "" Then
Worksheets("Ark1").Range("A4").End(xlDown).Select
End If
ActiveCell.Offset(1, 0).Select
ActiveCell.Value = nøgletal
ActiveCell.Offset(0, 1).Select
ActiveCell.Value = år
Worksheets("Ark2").Select
Worksheets("Ark2").Range("B2", "B16").Select
End Sub
Sub x()
Dim lngDataColumns As Long
Dim lngDataRows As Long
lngDataColumns = 3
lngDataRows = 15
For t = 1 To lngDataRows
Range("l2").Offset(((t - 1) * lngDataColumns) - 1, 0).Resize(lngDataColumns, 1).Value = _
Application.Transpose(Range("f1:h1").Value)
Range("M2").Offset(((t - 1) * lngDataColumns) - 1, 0).Resize(lngDataColumns, 1).Value = _
Application.Transpose(Range("f1:h1").Offset(t).Value)
Next t
End Sub
A Special Transpose Vol. 2
Adjust the values in the constants section to fit your needs.
The first data row in Range1 (A2:C2) has to have values.
The Code
Sub TransposeAH()
Const cSheet1 As Variant = "Ark1" ' Sheet1 Name/Index
Const cSheet2 As Variant = "Ark1" ' Sheet2 Name/Index
Const cFirst As Integer = 2 ' First Row Number
Const cCol1First As Variant = "A" ' Range1 First Column Letter/Number
Const cCol1Last As Variant = "C" ' Range1 Last Column Letter/Number
Const cCol2First As Variant = "F" ' Range2 First Column Letter/Number
Const cCol2Last As Variant = "H" ' Range2 Last Column Letter/Number
Const cColumns As Integer = 2 ' Number of New Columns
Const cFirstCell As String = "L1" ' Target Range First Cell Address
Dim vntH As Variant ' Range2 Headers
Dim vnt2 As Variant ' Range2 Array
Dim vnt3 As Variant ' Range1 Temp Array (if value is "")
Dim vnt1 As Variant ' Range1 Array
Dim vntT As Variant ' Target Array
Dim LastUR As Long ' Last Used Row
Dim i As Long ' Arrays Row Counter
Dim j As Integer ' Arrays Column Counter
Dim k As Long ' Target Array Rows Counter
Dim m As Integer ' Range1 Temp Array Column Counter
' From Sheet1 to Arrays.
With Worksheets(cSheet1)
' Calculate Last Used Row.
With .Range(.Cells(cFirst, cCol1First), .Cells(.Rows.Count, cCol2Last))
If .Find("*", .Cells(.Rows.Count, .Columns.Count), -4123, , 1) _
Is Nothing Then Exit Sub
LastUR = .Find("*", , , , , 2).Row
End With
' Paste ranges into arrays.
vnt1 = .Range(.Cells(cFirst, cCol1First), .Cells(LastUR, cCol1Last))
vnt2 = .Range(.Cells(cFirst, cCol2First), .Cells(LastUR, cCol2Last))
vntH = .Range(.Cells(cFirst - 1, cCol2First), _
.Cells(cFirst - 1, cCol2Last))
End With
' Resize Target Array.
ReDim vntT(1 To UBound(vnt2) * UBound(vnt2, 2), _
1 To cColumns + UBound(vnt1, 2))
' Write Range2 Array to Target Array.
For i = 1 To UBound(vnt2)
For j = 1 To UBound(vnt2, 2)
k = k + 1
vntT(k, 1) = vntH(1, j)
vntT(k, 2) = vnt2(i, j)
Next
Next
' Resize Range1 Temp Array (if value is "")
ReDim vnt3(1 To 1, 1 To UBound(vnt1, 2))
' Copy first line of Range1 Array to Range1 Temp Array.
For m = 1 To UBound(vnt3, 2)
vnt3(1, m) = vnt1(1, m)
Next
' Write Range1 Array to Target Array.
k = 0
For i = 1 To UBound(vnt1)
For j = 1 To UBound(vnt1, 2)
k = k + 1
For m = 1 To UBound(vnt2, 2)
If vnt1(i, m) <> "" Then
If vnt1(i, m) <> vnt3(1, m) Then
vnt3(1, m) = vnt1(i, m)
End If
End If
vntT(k, m + cColumns) = vnt3(1, m)
Next
Next
Next
' Paste Target Array into Target Range resized
' from Target Range First Cell Address.
With Worksheets(cSheet2).Range(cFirstCell)
.Resize(UBound(vntT), UBound(vntT, 2)) = vntT
End With
End Sub
I have to capture sheet row into a 2d array. I am using the following code
Code :
Sub multiarr()
Dim str As String 'String Which i am looking for
Dim result() As String 'Stores Splitted Substring
Dim r As Integer ' Row Counter of 2d array
Dim c As Integer ' Column Counter of 2d Array
Dim valarr() As String ' Initial Declaration of Array
'Row and Column Initialization
r = 0
c = 0
'Calculate Last Row and Last Column of Sheet
mylr = Cells(Rows.Count, 1).End(xlUp).Row
lcol = Cells(1, Columns.Count).End(xlToLeft).Column
'Initialize the Array according to Sheet Dimentions
ReDim valarr(mylr - 2, lcol - 1) 'Declare Array to be of size of Sheet
str = "M1" ' -> This i am interested in.Only these records will be populated
For y = 0 To UBound(valarr) 'iterate through rows of array
For x = 2 To mylr 'iterate through rows of sheet
result = Split(Cells(x, 1), "#") ' Split the Record
If result(0) = str Then 'Check for the Condition
'Array Filling Logic
For c = 1 To lcol
' C-1 because column index starts from 0
valarr(y, c - 1) = Cells(x, c)
Next c
End If
Next x
Next y
End Sub
But this code is incorrectly filling. What is the problem?
Please refer sample image of worksheet
Thanks in advance
Please see the bellow, hope it helps
Sub multiarr()
Dim str As String 'String Which i am looking for
Dim result() As String 'Stores Splitted Substring
Dim r As Integer ' Row Counter of 2d array
Dim c As Integer ' Column Counter of 2d Array
Dim valarr() As String ' Initial Declaration of Array
Dim mylr As Long, lcol As Long 'lastrow / lastcol
'I recommend declaring the workbook/worksheet and declaring the ranges accordingly
'Without doing so, any range refence bellow is explicit to the ActiveSheet
Dim arrValues As Variant
Dim cnt As Long, cnt2 As Long
'Row and Column Initialization
r = 1
c = 1
'Calculate Last Row and Last Column of Sheet
mylr = Cells(Rows.Count, 1).End(xlUp).row
lcol = Cells(1, Columns.Count).End(xlToLeft).column
arrValues = Range(Cells(r, c), Cells(mylr, lcol))
str = "M1" ' -> This i am interested in.Only these records will be populated
For y = LBound(arrValues) To UBound(arrValues) 'Iterate through values
If Left(arrValues(y, 1), 2) = str Then 'Check if the correct value exists
cnt = cnt + 1 'Count the number of occurences
End If
Next y
'Initialize the Array according to Results Dimentions
ReDim valarr(1 To cnt, 1 To lcol) 'Declare Array to be of size of Sheet
cnt2 = 1 'Start at one to match the array of the values, but... feel free to change
For y = LBound(arrValues) To UBound(arrValues) 'Iterate through array rows
If Left(arrValues(y, 1), 2) = str Then 'Check if the correct value exists
For z = LBound(arrValues, 2) To UBound(arrValues, 2) 'Iterate through array columns
valarr(cnt2, z) = arrValues(y, z) 'Add to the arr only correct values
Next z
cnt2 = cnt2 + 1 'If value find, we increase the counter
End If
Next y
End Sub
this answer only addresses the issue of getting a range into a 2-D array, not the processing of the elements.
This code is a pretty efficient method:
Sub multiarr()
Dim str As String 'String Which i am looking for
Dim result() As String 'Stores Splitted Substring
Dim r As Integer ' Row Counter of 2d array
Dim c As Integer ' Column Counter of 2d Array
Dim valarr()
valarr = Range("A1").CurrentRegion
MsgBox LBound(valarr, 1) & "-" & UBound(valarr, 1) & vbCrLf & LBound(valarr, 2) & "-" & UBound(valarr, 2)
End Sub
If you can't adapt the approach to your needs, ignore this answer.
Use auto filter (see comments in code):
Sub multiarr()
Dim rng As Range, rngData As Range, rngFilter As Range
'// Full range
Set rng = Range("A1").CurrentRegion
'// Range without a header
With rng
Set rngData = .Offset(1).Resize(.Rows.Count - 1)
End With
rng.AutoFilter Field:=1, Criteria1:="M1*"
'// Error handling in case if no rows will be filtered
On Error Resume Next
Set rngFilter = rngData.SpecialCells(xlCellTypeVisible)
If Err = 0 Then
'// Do something with your range.
'// Do not forget to use Areas,
'// since rngFilter can be non-contiguous:
'// Dim cell As Range, rngRow As Range, rngArea As Range
'// For Each rngArea in rngFilter.Areas
'// For Each cell in rngArea
'// 'Or For Each rngRow in rngArea.Rows
'// // Do something...
'// Next
'// Next
End If
On Error GoTo 0
End Sub