Sub clean()
Dim x As Long, lastrow As Long
Dim ws As Worksheet
Dim CleanAry
Set ws = ThisWorkbook.Sheets("Sheet1")
'copy Column B to C
'Range("B1:B1048576").Copy Destination:=ws.Range("C1:C1048576")
'array for clean up
CleanAry = Array("..", "__")
lastrow = ws.Range("C1048576").End(xlUp).Row
For Each cel In Range("C1:C" & lastrow)
For i = LBound(CleanAry) To UBound(CleanAry)
cel = cel.Replace(What:=CleanAry(i), _
Replacement:=".", _
Lookat:=xlPart, _
SearchOrder:=xlByRows, _
MatchCase:=False)
Next i
Next cel
End Sub
I am trying to create an array of string combinations that will parse through a particular column and remove those string combinations from the existing strings in the cells.
However, my code only seems to work when I have one string in my array, and not when I add additional strings. I get the error :
"object required" for the "cel=..." section.
Haven't really coded in VBA consistently. Do help me figure out what is going wrong.
You should probably add some checks if you expect there could ever be errors in the range being cleaned. The whole process would be much faster using an array.
Sub clean()
Dim x As Long, lastrow As Long
Dim ws As Worksheet
Dim CleanAry, v, arr, r As Long
Set ws = ThisWorkbook.Sheets("Sheet1")
'copy Column B to C
'Range("B1:B1048576").Copy Destination:=ws.Range("C1:C1048576")
CleanAry = Array("..", "__") 'array for clean up
lastrow = ws.Range("C1048576").End(xlUp).Row
arr = Range("C1:C" & lastrow).Value
For r = 1 to UBound(arr, 1)
v = arr(r, 1)
For i = LBound(CleanAry) To UBound(CleanAry)
v = Replace(v, CleanAry(i), ".")
Next i
arr(r, 1) = v
Next r
Range("C1:C" & lastrow).Value = arr
End Sub
Related
I'm looking for a way to create an array in which it finds the average for columns E, F, G and H and then stores the average in an array. The only issue is the amount of rows in each column varies for each file I will run this array on (all the columns have the same amount of rows though) and so I pressure it'll be a dynamic array, and I also want the averaging to start from the second row as I have titles in the first row. If anyone knows how to do this the help would be much appreciated as I'm utterly confused.
As far as I know, empty cells doesn't count. So there is no need to define lastrow. Try this:
Sub AvToArray()
Dim rng As Range
Dim col As Range
Dim arrAv()
Dim i As Long
Set rng = Range("E:H")
ReDim arrAv(rng.Columns.Count)
For Each col In rng.Columns
arrAv(i) = WorksheetFunction.Average(col)
i = i + 1
Next col
End Sub
You can use the WorksheetFunction method for Average().
From what I understood from your question, you wanted the averages to be stored inside an array, so here you go..
Public Function lastRow(ByVal ws As Worksheet, Optional ByVal col As Variant = 1)
With ws
lastRow = .Cells(.Rows.Count, col).End(xlUp).Row
End With
End Function
Sub test()
Dim ws As Worksheet, aveArr(4) As Double
Set ws = ThisWorkbook.Worksheets(1)
'You said that you wanted to store the values to be inside an array...
With WorksheetFunction
aveArr(0) = .Average(ws.Range("E2:E" & lastRow(ws, "E")))
aveArr(1) = .Average(ws.Range("F2:E" & lastRow(ws, "F")))
aveArr(2) = .Average(ws.Range("G2:E" & lastRow(ws, "G")))
aveArr(3) = .Average(ws.Range("H2:E" & lastRow(ws, "H")))
End With
MsgBox aveArr(0) & vbNewLine & _
aveArr(1) & vbNewLine & _
aveArr(2) & vbNewLine & _
aveArr(3)
End Sub
My (very similar) solution to the others posted here:
Sub AverageArray()
Dim myarray As Variant, sht As Worksheet, lastrow As Long
Set sht = ThisWorkbook.Worksheets("Sheet1")
lastrow = sht.Cells(sht.Rows.Count, "E").End(xlUp).Row 'or F, G, H, etc.
myarray = Array(Application.Average(Range("E2:E" & lastrow)), _
Application.Average(Range("F2:F" & lastrow)), _
Application.Average(Range("G2:G" & lastrow)), _
Application.Average(Range("H2:H" & lastrow)))
Debug.Print myarray(0)
Debug.Print myarray(1)
Debug.Print myarray(2)
Debug.Print myarray(3)
End Sub
This question is based on a tip I got in the forum some other day, but since this completely changed the problem I'm creating a new post (it seemed a much better solution than the one I proposed but I'm having some issues).
The rationale of my code is to search up and find entries based on ID in column A (from criteria input in txtbox); if the row matches the search criteria then I want the data from column A to J for that entry to be stored in a dynamic array. All the matching entries will be stored there. This array will be used to display all the relevant entries in a listbox in a userform.
The code is the following:
Private Sub cmdFind_Click()
Dim sht As Worksheet
Dim lastrow As Variant
Dim strSearch As String
Dim aCell As Range
Dim row_number As Integer
Dim item_in_review As Variant
Dim y As Integer
Dim Arr() As Variant
y = lstSearch.ListCount
Set sht = ActiveWorkbook.Sheets("a")
lastrow = sht.Range("A" & Rows.Count).End(xlUp).Row
strSearch = txtSearch.Text
Set aCell = sht.Range("A1:A" & lastrow).Find(What:=strSearch, LookIn:=xlValues, _
LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
MatchCase:=False, SearchFormat:=False)
If Not aCell Is Nothing Then
GoTo wfrefvalid
Else
MsgBox "Oops! That Work File does not exist. Please try again.", Title:="Try again"
txtSearch.Value = ""
End If
Exit Sub
wfrefvalid:
row_number = 0
'clears the listbox so that you have dont have a continuously growing list
lstSearch.Clear
Do
DoEvents
row_number = row_number + 1
ReDim Preserve Arr(item_in_review + 1)
item_in_review = sht.Range("A" & row_number)
If item_in_review = txtSearch.Text Then
Arr = item_in_review.Range("A" & row_number & ":J" & row_number)
End If
Loop Until item_in_review = ""
lstSearch.List = Arr
End Sub
The code isn't giving any debugging-errors, however it's also not doing anything when I press the search button. I think the area where I'm struggling is defining the array, and adding each entry to it as the find-function loops through the table (ie the last 12 or so pieces of code).
ANyone have any tips for adding the data from the search (including the extra columns) to the array?
I think the code would to be like this.
Private Sub cmdFind_Click()
Dim sht As Worksheet
Dim lastrow As Variant
Dim strSearch As String
Dim aCell As Range
Dim row_number As Integer
Dim item_in_review As Variant
Dim y As Integer
Dim Arr() As Variant
Dim rngDB As Range
Dim strAddress As String, n As Long
y = lstSearch.ListCount
Set sht = ActiveWorkbook.Sheets("a")
lastrow = sht.Range("A" & Rows.Count).End(xlUp).Row
Set rngDB = sht.Range("a1", "a" & lastrrow)
strSearch = txtSearch.Text
With rngDB
Set aCell = .Find(What:=strSearch, LookIn:=xlValues, _
LookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
MatchCase:=False, SearchFormat:=False)
If Not aCell Is Nothing Then
strAddress = aCell.Address
Do
n = n + 1
ReDim Preserve Arr(1 To 10, 1 To n)
For i = 1 To 10
Arr(i, n) = aCell(1, i)
Next i
Set aCell = .FindNext(aCell)
Loop While strAddress <> aCell.Address
Else
MsgBox "Oops! That Work File does not exist. Please try again.", Title:="Try again"
txtSearch.Value = ""
End If
End With
If n = 1 Then
lstSearch.List = Arr
ElseIf n > 1 Then
lstSearch.List = WorksheetFunction.Transpose(Arr)
End If
End Sub
Anybody please help me figure my problem out?
Dim attPresent as Variant ' attpresent()
Set ws = thisworkbook.sheets("Sheet1")
lastrow = ws.cells(Rows.count, 8).end(xlup).row
attPresent = ws.Range("H4:H" & lastrow).Value 'errors if I use Dim attPresent() As Variant
For k = LBound(attPresent, 1) To UBound(attPresent, 1) ' Dim attPresent As Variant'errors if I use
msgbox attpresent(k,1)
Next
This line attPresent = ws.Range("H4:H" & lastrow).Value returns an error if I declare the variable as Dim attPresent() As Variant. Whereas, if declare the variable as Dim attPresent As Variant, this line For k = LBound(attPresent, 1) To UBound(attPresent, 1) errors.
Can anyone please help me clear this out?Thanks
As a good practice, try to remember to use Option Explicit, and also declare all your variables.
When you use Dim attPresent() As Variant to declare you array , and later on you insert values from a Range to your Array with attPresent = .Range("H4:H" & lastrow).Value, it will automatically Redim your array to 2-dimensinal array (1 to Row number, 1 to Column Number).
Option Explicit
Sub RngtoArray()
Dim attPresent() As Variant
Dim ws As Worksheet
Dim lastrow As Long
Dim k As Long
Set ws = ThisWorkbook.Sheets("Sheet1")
With ws
lastrow = .Cells(.Rows.Count, 8).End(xlUp).Row
attPresent = .Range("H4:H" & lastrow).Value
End With
For k = 1 To UBound(attPresent, 1)
MsgBox attPresent(k, 1)
Next
End Sub
Edit 1: A slightly different approach, in case there is only 1 cell in the Range:
With ws
lastrow = .Cells(.Rows.Count, 8).End(xlUp).Row
' for single column only - create a 1-Dimension array
ReDim attPresent(1 To lastrow - 4 + 1) ' when the Range starts from "H4"
For k = 1 To UBound(attPresent)
attPresent(k) = .Cells(4 + k - 1, "H")
Next k
End With
For k = 1 To UBound(attPresent)
MsgBox attPresent(k)
Next
I tried to separate the stuff that you had already defined but for clarity I thought I'd provide my full code:
Sub test()
Dim lastrow, i As Integer
Dim ws As Worksheet
Set ws = ActiveWorkbook.Worksheets("Sheet1")
Dim attPresent() As Variant
lastrow = ws.Cells(Rows.Count, "H").End(xlUp).Row
ReDim attPresent(lastrow - 4)
For i = 4 To lastrow
attPresent(i - 4) = ws.Range("H" & i).Value
Next
msg = Join(attPresent, " ")
MsgBox "The array holds: " & vbNewLine & msg
End Sub
I defined the array without a size to begin with then redefined it to the size it needs to be at a later stage once you know the lastrow (as you started on 4 i deducted 4 from lastrow).
I guessed the msgBox was to test what you had gathered so I created a dump that prints them all into one box but obviously change that if you have a lot of data. xD
To work with arrays I always loop through each individual entry, storing them one at a time. I'm not even sure whether you can dump an entire range into one in one step as I've never even looked into it. Anyway, I hope this solves your problem kupo.
Function RangeToArray(rng As Range)
Dim myArray() As Variant, ws As Worksheet
fr = rng.Row
fc = rng.Column
r = rng.Rows.Count
c = rng.Columns.Count
Set ws = rng.Worksheet
ReDim myArray(r - 1, c - 1)
For i = 0 To r - 1
For j = 0 To c - 1
myArray(i, j) = ws.Cells(fr + i, fc + j).Value2
Next j
Next i
RangeToArray = myArray
End Function
Sub f()
Dim rng As Range, attPresent() As Variant ' attpresent()
Set ws = ThisWorkbook.ActiveSheet 'Sheets("Sheet1")
lastrow = ws.Cells(Rows.Count, 8).End(xlUp).Row
Set rng = ws.Range("H4:H" & lastrow)
attPresent = RangeToArray(rng)
For k = LBound(attPresent, 1) To UBound(attPresent, 1) ' Dim attPresent As Variant'errors if I use
MsgBox attPresent(k, 0)
Next
End Sub
I created a more generic function that you can call in this specific case as well.
I am stuck with the Problem described in the headline. I am populating a TreeView from strings using and adapted Version of #Siddharth Rout 's approach (https://stackoverflow.com/a/21457669/6564572). However, if I only have one entry in the respective range I get a "Runtime Error 13 - Type mismatch". I tried manually Setting i = 1 to UBound(MyAr) and a few other things but needless to say, it did not work. If there are 2 or more entries, it runs through smoothly.
Any help would be greatly appreciated.
Dim ws As Worksheet, wsNew As Worksheet
Dim MyAr As Variant, TempAr As Variant
Dim LRow As Long, lCol As Long
Dim i As Long, j As Long, k As Long, r As Long, Level As Long
Dim delRange As Range
Dim sFormula As String, stemp1 As String, stemp2 As String
Set ws = ThisWorkbook.Sheets("Supplier Skills")
ws.Columns(1).Sort Key1:=ws.Range("A2"), _
Order1:=xlAscending, Header:=xlNo, OrderCustom:=1, _
MatchCase:=False, Orientation:=xlTopToBottom, DataOption1:=xlSortNormal
Dim f As Range
Dim ColumnLetter As String
Set f = ws.Range("A1:ZZ1").Find(What:=UserForm1.SESNo, LookIn:=xlValues, Lookat:=xlWhole, MatchCase:=False)
ColumnLetter = Split(f.Address, "$")(1)
LRow = ws.Range(ColumnLetter & "30").End(xlUp).row
MyAr = ws.Range(ColumnLetter & "2:" & ColumnLetter & LRow).value
Set wsNew = ThisWorkbook.Worksheets("Selected TreeView")
wsNew.Range("A1:D30").Clear
r = 2: k = 3
With wsNew
For i = LBound(MyAr) To UBound(MyAr) '<<<<<<<<<<<<<<<--ERROR HERE--<<<<<<<<<<<
TempAr = Split(MyAr(i, 1), "\")
Level = UBound(TempAr) - 1
.Range("B" & r).value = TempAr(1)
.
. 'same as in original code
.
If there's only 1 item in MyAr it's not set-up as an array yet, so you can try the following workaround when MyAr will reslut with only 1 element:
If IsArray(MyAr) Then
For i = LBound(MyAr) To UBound(MyAr)
' do your loop things here
Next i
Else
' only 1 element in array
End If
For everyone else wondering the same in the future, I followed Shai Rado's tip, with the following Addition:
If IsArray(MyAr) Then
For i = LBound(MyAr) To UBound(MyAr)
'Loops here
Next i
Else
Dim myElements() As String
myElements = Split(ws.Range(ColumnLetter & "2").value, "\")
wsNew.Range("B2") = myElements(0)
wsNew.Range("C3") = myElements(1)
wsNew.Range("C4") = myElements(2)
End If
I just declared the range where the string-parts need to be copied to manually after splitting the Array. It is easy since you should know exactly at what column/row number the extra-case will occur for each entry.
I want to optimize the following code, as it is very slow.
I am using the code found in this answer:
https://stackoverflow.com/a/27108055/1042624
However, it is very slow when looping through +10k rows. Is it possible to optimize my code below? I have tried to modify it a bit, but it does not seem to work.
Sub DeleteCopy2()
Dim LastRow As Long
Dim CurRow As Long
Dim DestLast As Long
Dim strSheetName As String
Dim arrVal() As Long
Application.ScreenUpdating = False
Application.Calculation = xlManual
strSheetName = "Week " & ISOWeekNum(Format(Date)) - 1
LastRow = Sheets("MatchData").Range("A" & Rows.Count).End(xlUp).Row
DestLast = Sheets(strSheetName).Range("A" & Rows.Count).End(xlUp).Row
ReDim arrVal(2 To LastRow) ' Headers in row 1
For CurRow = LBound(arrVal) To UBound(arrVal)
If Not Sheets(strSheetName).Range("A2:A" & DestLast).Find(Sheets("MatchData").Range("A" & CurRow).Value, LookIn:=xlValues, LookAt:=xlWhole) Is Nothing Then
Sheets("MatchData").Range("A" & CurRow).Value = ""
Else
End If
Next CurRow
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
End Sub
Can you try this for me? I have commented the code so that you will not have a problem understanding it. Also check how much time it takes for 10k+ rows
Logic
Store search values in array 1
Store destination values in array 2
Loop through the first array and check if it is present in the second array. If present, clear it
Clear the search values from sheet1
Output the array to the sheet1
Sort Col A so that the blanks go down.
Code
Sub Sample()
Dim wbMatch As Worksheet, wbDestSheet As Worksheet
Dim lRow As Long, i As Long
Dim MArr As Variant, DArr As Variant
Dim strSheetName As String
Dim rng As Range
strSheetName = "Sheet2" '"Week " & IsoWeekNum(Format(Date)) - 1
'~~> Set your worksheets
Set wbMatch = Sheets("MatchData")
Set wbDestSheet = Sheets(strSheetName)
'~~> Store search values in 1st array
With wbMatch
lRow = .Range("A" & .Rows.Count).End(xlUp).Row
Set rng = .Range("A2:A" & lRow)
MArr = rng.Value
End With
'~~> Store destination values in the 2nd array
With wbDestSheet
lRow = .Range("A" & .Rows.Count).End(xlUp).Row
DArr = .Range("A2:A" & lRow).Value
End With
'~~> Check if the values are in the other array
For i = LBound(MArr) To UBound(MArr)
If IsInArray(MArr(i, 1), DArr) Then MArr(i, 1) = ""
Next i
With wbMatch
'~~> Clear the range for new output
rng.ClearContents
'~~> Output the array to the worksheet
.Range("A2").Resize(UBound(MArr), 1).Value = MArr
'~~> Sort it so that the blanks go down
.Columns(1).Sort Key1:=.Range("A2"), Order1:=xlAscending, Header:=xlYes, OrderCustom:=1, _
MatchCase:=False, Orientation:=xlTopToBottom, DataOption1:=xlSortNormal
End With
End Sub
'~~> function to check is a value is in another array
Function IsInArray(stringToBeFound As Variant, arr As Variant) As Boolean
Dim j As Long
For j = 1 To UBound(arr, 1)
On Error Resume Next
IsInArray = Application.Match(stringToBeFound, Application.Index(arr, , i), 0)
On Error GoTo 0
If IsInArray = True Then Exit For
Next
End Function
Edit
Another way. Based on the sample file, this code runs in approx 1 minute.
Start : 8/4/2016 08:59:36 PM
End : 8/4/2016 09:00:47 PM
Logic:
It uses CountIf to check for duplicates and then deletes the duplicates using .Autofilter
Sub Sample()
Dim wbMatch As Worksheet, wbDestSheet As Worksheet
Dim lRow As Long
Dim strSheetName As String
Dim rng As Range
Debug.Print "Start : " & Now
strSheetName = "Week " & ISOWeekNum(Format(Date)) - 1
'~~> Set your worksheets
Set wbMatch = Sheets("MatchData")
Set wbDestSheet = Sheets(strSheetName)
'~~> Store search values in 1st array
With wbMatch
lRow = .Range("A" & .Rows.Count).End(xlUp).Row
.Columns(2).Insert
Set rng = .Range("B2:B" & lRow)
lRow = wbDestSheet.Range("A" & wbDestSheet.Rows.Count).End(xlUp).Row
rng.Formula = "=COUNTIF('" & strSheetName & "'!$A$1:$A$" & lRow & ",A2)"
DoEvents
rng.Value = rng.Value
.Range("B1").Value = "Temp"
'Remove any filters
.AutoFilterMode = False
With .Range("A1:E" & lRow) 'Filter, offset(to exclude headers) and delete visible rows
.AutoFilter Field:=2, Criteria1:=">0"
.Offset(1, 0).SpecialCells(xlCellTypeVisible).EntireRow.Delete
End With
'Remove any filters
.AutoFilterMode = False
.Columns(2).Delete
End With
Debug.Print "End : " & Now
End Sub
Looks like #SiddarthRout and I were working in parallel...
My code example below executes in less than 2 secs (eyeball estimate) over almost 12,000 rows.
Option Explicit
Sub DeleteCopy2()
Dim codeTimer As CTimer
Set codeTimer = New CTimer
codeTimer.StartCounter
Dim thisWB As Workbook
Dim destSH As Worksheet
Dim matchSH As Worksheet
Set thisWB = ThisWorkbook
Set destSH = thisWB.Sheets("Week 32")
Set matchSH = thisWB.Sheets("MatchData")
Dim lastMatchRow As Long
Dim lastDestRow As Long
lastMatchRow = matchSH.Range("A" & matchSH.Rows.Count).End(xlUp).Row
lastDestRow = destSH.Range("A" & matchSH.Rows.Count).End(xlUp).Row
'--- copy working data into memory arrays
Dim destArea As Range
Dim matchData As Variant
Dim destData As Variant
matchData = matchSH.Range("A1").Resize(lastMatchRow, 1)
Set destArea = destSH.Range("A1").Resize(lastDestRow, 1)
destData = destArea
Dim i As Long
For i = 2 To lastDestRow
If Not InMatchingData(matchData, destData(i, 1)) Then
destData(i, 1) = ""
End If
Next i
'--- write the marked up data back to the worksheet
destArea = destData
Debug.Print "Destination rows = " & lastDestRow
Debug.Print "Matching rows = " & lastMatchRow
Debug.Print "Execution time = " & codeTimer.TimeElapsed & " secs"
End Sub
Private Function InMatchingData(ByRef dataArr As Variant, _
ByRef dataVal As Variant) As Boolean
Dim i As Long
InMatchingData = False
For i = LBound(dataArr) To UBound(dataArr)
If dataVal = dataArr(i, 1) Then
InMatchingData = True
Exit For
End If
Next i
End Function
The timing results from my code are (using the timer class from this post ):
Destination rows = 35773
Matching rows = 23848
Execution time = 36128.4913359179 secs