I have this little code that replaces the letters from a table like this (find the left string and replace it with the right string):
However it takes a great amount of time to do all the replacements in the sheets I have (just 2). Nearly 10 seconds. Is there a way to speed this up pls? Many thanks for taking the time!!
Dim sht As Worksheet
Dim fndList As Integer
Dim rplcList As Integer
Dim tbl As ListObject
Dim myArray As Variant
Dim ReplaceCount As Long
Set sht = Sheets("Sheet1")
Application.ScreenUpdating = False
'Create variable to point to your table
Set tbl = Worksheets("Sheet1").ListObjects("StringReplace")
'Create an Array out of the Table's Data
Set TempArray = tbl.DataBodyRange
myArray = Application.Transpose(TempArray)
'Designate Columns for Find/Replace data
fndList = 1
rplcList = 2
'Loop through each item in Array lists
For x = LBound(myArray, 1) To UBound(myArray, 2)
'Loop through each worksheet in ActiveWorkbook (skip sheet with table in it)
For Each sht In ActiveWorkbook.Worksheets
If sht.Name <> tbl.Parent.Name Then
sht.Cells.Replace What:=myArray(fndList, x), Replacement:=myArray(rplcList, x), _
LookAt:=xlPart, SearchOrder:=xlByRows, MatchCase:=False, _
SearchFormat:=False, ReplaceFormat:=False
End If
Next sht
Next x
Application.ScreenUpdating = True
Replace Strings in Multiple Worksheets
The Code
Option Explicit
Sub replaceOddStrings()
Const WorksheetName As String = "Sheet1"
Const TableName As String = "StringReplace"
Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
Dim Data As Variant: Data = wb.Worksheets(WorksheetName) _
.ListObjects(TableName).DataBodyRange.Value
Dim ws As Worksheet
Dim i As Long
Application.ScreenUpdating = False
For Each ws In wb.Worksheets
If ws.Name <> WorksheetName Then
For i = 1 To UBound(Data, 1)
ws.UsedRange.Replace Data(i, 1), Data(i, 2), xlPart, , False, _
False, False, False
Next i
End If
Next ws
Application.ScreenUpdating = True
MsgBox "Strings replaced.", vbInformation, "Success"
End Sub
Related
I have several excel sheets with tables with a similar format to below:
Where I'd like to copy all the rows where the number under the "Value" header exceeds 10 into a blank tab.
Sub Copy_Criteria()
With Range("A5:P1000")
.AutoFilter Field:=15, Criteria1:=">10"
End With
End Sub
After that I would like to select all the values filtered here and copy them into a blank sheet. Next I'd like to repeat the whole process, but copying the rows based on another header/criteria into a second blank tab.
Thanks!
You can do something like this:
With Range("A5:P1000")
.AutoFilter Field:=15, Criteria1:=">30"
On Error Resume Next 'in case no visible cells
.SpecialCells(xlCellTypeVisible).Copy Sheet2.Range("a1")
On Error Goto 0
.Parent.ShowAllData 'clear filter
End With
Copy By Criteria
Adjust the values in the constants section.
Option Explicit
Sub CopyByCriteria()
' Needs 'RefCurrentRegionBottomRight', 'GetFilteredRange' and 'GetRange'.
Const ProcTitle As String = "CopyByCriteria"
Const sFirst As String = "A5"
Dim swsNames As Variant: swsNames = Array("Sheet1", "Sheet2", "Sheet3")
Const dFirst As String = "A1"
' These three arrays need to have the same number of elements.
Dim dwsNames As Variant: dwsNames = Array("15gt10", "12gt15")
Dim dFields As Variant: dFields = Array(15, 12)
Dim dCriteria As Variant: dCriteria = Array(">10", ">15")
Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
Dim sws As Worksheet
Dim srg As Range
Dim dws As Worksheet
Dim drg As Range
Dim dCell As Range
Dim dData As Variant
Dim n As Long
Dim IncludeHeaders As Boolean
For n = LBound(dwsNames) To UBound(dwsNames)
On Error Resume Next
Application.DisplayAlerts = False
wb.Sheets(dwsNames(n)).Delete
Application.DisplayAlerts = True
On Error GoTo 0
Set dws = wb.Worksheets.Add(After:=wb.Sheets(wb.Sheets.Count))
dws.Name = dwsNames(n)
Set dCell = dws.Range(dFirst)
IncludeHeaders = True
For Each sws In wb.Worksheets(swsNames)
Set srg = RefCurrentRegionBottomRight(sws.Range(sFirst))
dData = GetFilteredRange( _
srg, dFields(n), dCriteria(n), IncludeHeaders, IncludeHeaders)
If Not IsEmpty(dData) Then
IncludeHeaders = False ' include only the first time
Set drg = dCell.Resize(UBound(dData, 1), UBound(dData, 2))
drg.Value = dData
Set dCell = dCell.Offset(UBound(dData, 1))
End If
Next sws
Next n
MsgBox "Worksheets created. Values copied.", vbInformation, ProcTitle
End Sub
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Purpose: Returns the filtered values of a range ('rg')
' in a 2D one-based array.
' Remarks: If ˙rg` refers to a multi-range, only its first area
' is considered.
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Function GetFilteredRange( _
ByVal rg As Range, _
ByVal fField As Long, _
ByVal fCriteria As String, _
Optional ByVal IncludeHeaders As Boolean = True, _
Optional ByVal AllowHeadersOnly As Boolean = False) _
As Variant
' Needs the 'GetRange' function.
Const ProcName As String = "GetFilteredRange"
On Error GoTo ClearError
Dim ws As Worksheet: Set ws = rg.Worksheet
If ws.AutoFilterMode Then
ws.AutoFilterMode = False
End If
rg.AutoFilter fField, fCriteria
Dim frShift As Long: frShift = IIf(IncludeHeaders, 0, 1)
Dim frg As Range
On Error Resume Next
Set frg = rg.Resize(rg.Rows.Count - frShift) _
.Offset(frShift).SpecialCells(xlCellTypeVisible)
On Error GoTo ClearError
ws.AutoFilterMode = False
If Not frg Is Nothing Then
Dim frCount As Long
frCount = Intersect(frg, ws.Columns(frg.Column)).Cells.Count
Dim doContinue As Boolean: doContinue = True
If frShift = 0 Then
If frCount = 1 Then
If Not AllowHeadersOnly Then
doContinue = False
End If
End If
End If
If doContinue Then
Dim fcCount As Long: fcCount = frg.Columns.Count
Dim dData As Variant: ReDim dData(1 To frCount, 1 To fcCount)
Dim tData As Variant
Dim arg As Range
Dim ar As Long
Dim c As Long
Dim dr As Long
Dim trCount As Long
For Each arg In frg.Areas
tData = GetRange(arg)
For ar = 1 To arg.Rows.Count
dr = dr + 1
For c = 1 To fcCount
dData(dr, c) = tData(ar, c)
Next c
Next ar
Next arg
GetFilteredRange = dData
'Else ' frShift = 0: frCount = 1: AllowHeadersOnly = False
End If
'Else ' no filtered range
End If
ProcExit:
Exit Function
ClearError:
Debug.Print "'" & ProcName & "': Unexpected Error!" & vbLf _
& " " & "Run-time error '" & Err.Number & "':" & vbLf _
& " " & Err.Description
Resume ProcExit
End Function
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Purpose: Returns the values of a range ('rg') in a 2D one-based array.
' Remarks: If ˙rg` refers to a multi-range, only its first area
' is considered.
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Function GetRange( _
ByVal rg As Range) _
As Variant
If rg Is Nothing Then Exit Function
If rg.Rows.Count + rg.Columns.Count = 2 Then ' one cell
Dim Data As Variant: ReDim Data(1 To 1, 1 To 1): Data(1, 1) = rg.Value
GetRange = Data
Else ' multiple cells
GetRange = rg.Value
End If
End Function
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Purpose: Returns a reference to the range starting with a given cell
' and ending with the last cell of its Current Region.
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Function RefCurrentRegionBottomRight( _
ByVal FirstCellRange As Range) _
As Range
If FirstCellRange Is Nothing Then Exit Function
With FirstCellRange.Cells(1).CurrentRegion
Set RefCurrentRegionBottomRight = _
FirstCellRange.Resize(.Row + .Rows.Count - FirstCellRange.Row, _
.Column + .Columns.Count - FirstCellRange.Column)
End With
End Function
In worksheet wsb,I am trying to copy column B and Column having ParName in header and pasting it to columns B & H respectively of worksheet wso. The problem is It's running only for first Item and also for the first matched value of i for that item and not for all the matched item-i values.
Dim ws, wsa, wsb, wsc, wso As Worksheet
Dim index1b, LastRow, MOLastRow, wsoLastRow As Long
Dim ColLtr1b As Variant
Dim MoNameArr
Set wsb = Workbooks(Y).Sheets("REF")
wsb.Activate
LastRow = GetLastRow(wsb, 2)
Arr = Array("Abc", "Def")
Set wso = Workbooks(W).Sheets("Output")
For Each Item In Arr
For i = 2 To LastRow
If Cells(i, 2).Value = Item Then
wsb.Activate
ParName = wsb.Cells(i, 3).Value
Set wsc = Workbooks(M).Sheets(Item)
wsc.Activate
index1b = Application.Match(ParName, wsc.Rows(1), 0)
If Not IsError(index1b) Then
ColLtr1b = Replace(wsc.Cells(1, index1b).Address(True, False), "$1", "")
MOLastRow = wsc.Cells(Rows.Count, 2).End(xlUp).Row
Range("B2:B" & GetLastRow(wsc, 2)).Copy
wso.Activate
wsoLastRow = GetLastRow(wso, 2)
Range("B" & wsoLastRow + 1).Select
ActiveSheet.Paste
wsc.Activate
Range(ColLtr1b & "2:" & ColLtr1b & GetLastRow(wsc, 2)).Copy
wso.Activate
Range("H" & wsoLastRow + 1).Select
ActiveSheet.Paste
End If
End If
Next i
Next Item
Declare your variables like this:
Dim ws As Worksheet, wsa As worksheet, wsb as Worksheet
Dim wsc as Worksheet, wso As Worksheet
Dim index1b as Long, LastRow as Long, MOLastRow as Long, wsoLastRow As Long
Then start debugging with pressing F8. It goes line by line and you may see where is the problem in the nested loop. It can be in one of these 3:
you need to write Trim(Cells(i, 2)) in the If Cells(i, 2).Value = Item Then condition;
you are not calculating LastRow correctly;
you have On Error Resume Next somewhere in your code and you are entering an error w/o noticing;
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
I am working on a project that involves finding a particular column in a spreadsheet, then storing only unique values in that column into an array and then printing that array on another sheet. My code is erroring out due to both a type mismatch and a with block not being set, but I can't seem to figure out why. Any help would be greatly appreciated.
Option Explicit
Sub Find_Distincts_Policies()
Dim aCell As Range, rng As Range
Dim varIn As Variant, varUnique As Variant, element As Variant
Dim isUnique As Boolean
Dim ws As Worksheet
Dim wkb As Workbook
Dim colName As Long
Dim i As Long, j As Long, k As Long
Dim iInCol As Long, iInRow As Long, iUnique As Long, nUnique As Long, LastRow As Long
Set wkb = ThisWorkbook
Set ws = wkb.Worksheets("Sheet2")
With ws
Set aCell = .Range("A1:ZZ4").Find(what:="Unique Number", LookIn:=xlValues, lookat:=xlWhole, MatchCase:=False)
If Not aCell Is Nothing Then
colName = Split(.Cells(, aCell).Address, "$")(1)
LastRow = .Cells(.Rows.Count, 1).End(xlUp).Row
Set rng = .Range(colName & "2:" & colName & LastRow)
varIn = rng.Value
ReDim varUnique(1 To UBound(varIn, 1) * UBound(varIn, 2))
nUnique = 0
For iInRow = LBound(varIn, 1) To UBound(varIn, 1)
For iInCol = LBound(varIn, 2) To UBound(varIn, 2)
isUnique = True
For iUnique = 1 To nUnique
If varIn(iInRow, iInCol) = varUnique(iUnique) Then
isUnique = False
Exit For
End If
Next iUnique
If isUnique = True Then
nUnique = nUnique + 1
varUnique(nUnique) = varIn(iInRow, iInCol)
End If
Next iInCol
Next iInRow
ReDim Preserve varUnique(1 To nUnique)
MsgBox varUnique
Else: Exit Sub
End If
End With
With wkb
.Worksheets.Add.Name = "Unique values"
ActiveSheet.Range("A1") = varIn
End With
End Sub
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