I have two buttons which cycles through records (employees in this case).
Button one is Previous Record and it will navigate through all the emoloyees up till the first emoloyee. After reaching first employee, the button won't do anything.
But, for the *next record * button, for some reason, after going to the last visible employ, pressing it once again will go to a new or **blank ** record.
Not sure how to fix the bug,
Help is highly appreciated thanks!
Sub WinLossSplit()
Dim ws As Worksheet
Application.DisplayAlerts = False
Application.ScreenUpdating = False
For Each ws In Worksheets
If ws.Name <> "Sheet1" And ws.Name <> "Sheet2" Then
If Application.WorksheetFunction.CountA(ws.Range("A:A")) > 0 Then
ws.Range("A:A").TextToColumns Destination:=ws.Range("A:B"), DataType:=xlDelimited, _
TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=False, _
Semicolon:=False, Comma:=True, Space:=False, Other:=True, OtherChar _
:=True, FieldInfo:=Array(Array(1, 1), Array(2, 1)), TrailingMinusNumbers:=True
End If
End If
Next ws
Application.DisplayAlerts = True
Application.ScreenUpdating = True
MsgBox ("done")
End Sub
Sub hello()
Dim a, i As Long, w(), k(), n As Long
Dim dic As Object, ws As Worksheet, s As String
For Each ws In Worksheets
dic.comparemode = vbTextCompare
'With Sheets("Sheet1")
a = ws.Range("a1:b" & ws.Range("a" & Rows.Count).End(xlUp).Row)
'End With
ReDim w(1 To UBound(a, 1), 1 To 2)
Set dic = CreateObject("scripting.dictionary")
For i = 1 To UBound(a, 1)
If Not IsEmpty(a(i, 1)) Then
' If Not dic.exists(a(i, 1)) Then
' n = n + 1
' w(n, 1) = a(i, 1): w(n, 2) = a(i, 2)
' dic.Add a(i, 1), Array(n, 2)
'Else
k = dic.Item(a(i, 1))
w(k(0), 2) = w(k(0), 2) & "," & a(i, 2)
dic.Item(a(i, 1)) = k
'End If
End If
Next
On Error Resume Next
'Set ws = Sheets("FinalReport")
On Error GoTo 0
If ws Is Nothing Then
' Set ws = Worksheets.Add: ws.Name = "FinalReport"
End If
With ws.Range("a1")
'.Resize(, 2).Value = Array("Array", "Datetime period")
.Resize(, 1).Value = Array("Array", "Datetime period")
For i = 1 To n
If Len(w(i, 2)) > 1024 Then
s = w(i, 2)
.Offset(i).Value = w(i, 1)
.Offset(i, 1).Value = s
Else
.Offset(i).Value = w(i, 1)
.Offset(i, 1).Value = w(i, 2)
End If
Next
' puts in separate columns rather than string with commas
.Offset(1, 1).Resize(n).TextToColumns _
Destination:=.Offset(1, 1), DataType:=xlDelimited, Comma:=True
End With
Set dic = Nothing: Erase a
Next ws
End Sub
It's not a bug, it's by design.
If you don't like this, set the form's property AllowAdditions to False.
Related
I want to compare two set of rows, data from sheet "Calculated Structure" is compared against data from sheet "MAP" and if it is a match return the value in last column.
Based on other responses I have the following code which joins the rows into a string and then leverages dictionary to perform the compare. I am using dictionary to improve performance as I am comparing MAP and DATA that are both 50,000+ records.
Sub CheckRows()
Dim cl As Range
Dim Ws1 As Worksheet
Dim Ws2 As Worksheet
Dim Vlu As String
Dim VluD As String
Dim Lc As Long
Dim x As Long
Dim i As Long
Dim ArrRslt() As Variant
Dim iRw As Long
Dim LastRow As Long
Dim RngTrgt As Range
Dim dict As New Scripting.Dictionary
Set Ws1 = Sheets("Calculated Structure")
Set Ws2 = Sheets("Map")
Lc = Ws2.Cells(2, Columns.Count).End(xlToLeft).Column - 1
RsltCol = Ws1.Cells.Find("*", LookIn:=xlFormulas, SearchOrder:=xlByColumns, _
SearchDirection:=xlPrevious).Column
For icntr = RsltCol To 1 Step -1
If Cells(1, icntr).value = "Calced Result" Then
Columns(icntr).Delete
End If
Next
LastCol = Ws1.Cells.Find("*", LookIn:=xlFormulas, SearchOrder:=xlByColumns, _
SearchDirection:=xlPrevious).Column
Cells(1, LastCol + 1).value = "Calced Result"
i = 1
x = 1
ReDim ArrRslt(0)
With CreateObject("scripting.dictionary")
dict.CompareMode = 1
For Each cl In Ws2.Range("A1", Ws2.Range("A" & Rows.Count).End(xlUp))
Vlu = Join(Application.Index(cl.RESIZE(, Lc).value, 1, 0), "|")
dict.Add key:=Vlu, Item:=(Ws2.Cells(i, Lc + 1))
i = i + 1
Next cl
For Each cl In Ws1.Range("B2", Ws1.Range("B" & Rows.Count).End(xlUp))
VluD = Join(Application.Index(cl.RESIZE(, Lc).value, 1, 0), "|")
If dict.Exists(VluD) Then
CResult = dict(VluD)
ArrRslt(x - 1) = CResult
Else
ArrRslt(x - 1) = "?"
End If
ReDim Preserve ArrRslt(0 To x)
x = x + 1
Next cl
End With
LastRow = Ws1.Cells.Find("*", LookIn:=xlFormulas, SearchOrder:=xlByRows, _
SearchDirection:=xlPrevious).Row
Set RngTrgt = Ws1.Range(Cells(2, Lc + 2), Cells(LastRow, Lc + 2))
RngTrgt = Application.WorksheetFunction.Transpose(ArrRslt)
MsgBox "Mapping Complete!"
End Sub
Some instances row on "MAP" have wildcard("*") designated as the cell value.
For example MAP looks like:
Check 1
Check 2
Check 3
Result
ABC
DEF
123
R1
ABC
*
123
R2
And my data looks like:
Field 1
Field 2
Field 3
Expected Result
ABC
DEF
123
R1
ABC
GHI
123
R2
For my second row of data I expect to return "R2" because in the MAP check 2 is wildcarded, so any value for Field 2 should pass. Instead the "?" is returned indicating no match found. My understanding is that this is because string "ABC|GHI|123" is not defined in the map.
What can I do to account for the wildcard values?
I feel I need to evaluate each "Check/Field" individually. Meaning first see if match found for Check 1, if so search for match for Check 2, so on till all matches are found.
I tried nested dictionaries. I believe that I am able to assign values appropriate but hitting a Run-time Error '450' when trying to retrieve information from the dictionaries. Here is my code:
Sub theDictionary()
Dim cl As Range
Dim WsRslt As Worksheet
Dim WsMap As Worksheet
Dim Vlu As String
Dim VluD As String
Dim Lc As Long
Dim MapVl As Long
Dim RsltCol As Long
Dim icntr As Long
Dim LastCol As Long
Dim rCount As Long
Dim mCount As Long
Dim x As Long
Dim i As Long
Dim dictCount As Long
Dim ArrRslt() As Variant
Dim iRw As Long
Dim LastRow As Long
Dim previousCell As String
Dim cResult As String
Dim RngTrgt As Range
Dim dict As New Scripting.Dictionary
Dim subDict() As Object
Set WsRslt = Sheets("Calculated Structure")
Set WsMap = Sheets("Map")
MapVl = WsMap.Cells(2, Columns.Count).End(xlToLeft).Column
Lc = MapVl - 1
MsgBox "Map value=" & MapVl & "and LC=" & Lc
RsltCol = WsRslt.Cells.Find("*", LookIn:=xlFormulas, SearchOrder:=xlByColumns, _
SearchDirection:=xlPrevious).Column
For icntr = RsltCol To 1 Step -1
If Cells(1, icntr).value = "Calced Result" Then
Columns(icntr).Delete
End If
Next
LastCol = WsRslt.Cells.Find("*", LookIn:=xlFormulas, SearchOrder:=xlByColumns, _
SearchDirection:=xlPrevious).Column
Cells(1, LastCol + 1).value = "Calced Result"
i = 1
x = 1
dictCount = 1
rCount = 1
ReDim ArrRslt(0)
previousCell = ""
ReDim subDict(1 To MapVl - 1)
For dictCount = 1 To MapVl - 1
Set subDict(dictCount) = New Scripting.Dictionary
subDict(dictCount).CompareMode = vbTextCompare
Next dictCount
For Each cl In WsMap.Range("A2", WsMap.Range("A" & Rows.Count).End(xlUp))
For rCount = 1 To MapVl - 1
'get the first item and add it to the subdictionary
' MsgBox "MapVl=" & MapVl & " and rCount=" & rCount
If rCount = 1 Then
If subDict(rCount).Exists(cl.Offset(0, MapVl - (rCount + 1)).Value2) Then
' MsgBox cl.Offset(0, MapVl - (rCount + 1)) & " Exists"
Else
' MsgBox cl.Offset(0, MapVl - (rCount + 1)) & " First Add"
subDict(rCount).Add CStr(cl.Offset(0, MapVl - (rCount + 1)).Value2), CStr(cl.Offset(0, MapVl - rCount).Value2)
End If
ElseIf rCount < MapVl Then
subDict(rCount).Add CStr(cl.Offset(0, MapVl - (rCount + 1)).Value2), subDict(rCount - 1)
End If
' MsgBox "Prev Cell Blank=" & previousCell & "cl.value=" & cl.value
Next rCount
rCount = 1
Next cl
For Each cl In WsRslt.Range("B2", WsRslt.Range("B" & Rows.Count).End(xlUp))
For mCount = 1 To MapVl - 1
VluD = cl.Value2 'Join(Application.Index(cl.RESIZE(, Lc).value, 1, 0), "|")
MsgBox "Cell Value=" & VluD
If subDict(MapVl - mCount).Exists(VluD) Then
MsgBox "VluD= " & VluD
cResult = subDict(MapVl - mCount).Item(VluD) '<-- Run-time error '450': Wrong number of arguments or invalid property assignment
ArrRslt(x - 1) = cResult
MsgBox "cResult=" & cResult
Else
ArrRslt(x - 1) = "?"
End If
ReDim Preserve ArrRslt(0 To x)
x = x + 1
Next mCount
Next cl
LastRow = WsRslt.Cells.Find("*", LookIn:=xlFormulas, SearchOrder:=xlByRows, _
SearchDirection:=xlPrevious).Row
Set RngTrgt = WsRslt.Range(Cells(2, Lc + 2), Cells(LastRow, Lc + 2))
RngTrgt = Application.WorksheetFunction.Transpose(ArrRslt)
MsgBox "Mapping Complete!"
End Sub
Once I am able to read the values, I still need to figure out how I am going to account for the "wildcard" values in MAP.
Any guidance is greatly appreciated.
I want a cod that will find duplicates and return it in separate array.
So I found a code that would be perfect for me, but the thing is that this code is removing duplicates. I thought that it will be a simple job to change it, but somehow I cannot manage to do it....
I was thinking that it will be in this part of code If Err.Number <> 0 Then coll.Remove txt but have no idea how to change it. I have tried changing <> with = but it seems not to work.
Can someone tell me where and how should I change the code to get duplicates from 2 arrays.
Sub test()
Dim arr1 As Variant
Dim arr2 As Variant
Dim arr3 As Variant
Dim coll As Collection
Dim I As Long, j As Long, ii As Long, txt As String, x
With Worksheets("Sheet1")
LastRowColumnA = .Cells(.Rows.Count, 1).End(xlUp).Row
arr1 = .Range("A2:C" & LastRowColumnA).Value
End With
With Worksheets("Sheet2")
LastRowColumnA = .Cells(.Rows.Count, 1).End(xlUp).Row
arr2 = .Range("A2:C" & LastRowColumnA).Value
End With
Set coll = New Collection
On Error Resume Next
For I = LBound(arr1, 1) To UBound(arr1, 1)
txt = Join(Array(arr1(I, 1), arr1(I, 2), arr1(I, 3)), Chr(2))
coll.Add txt, txt
Next I
For I = LBound(arr2, 1) To UBound(arr2, 1)
txt = Join(Array(arr2(I, 1), arr2(I, 2), arr2(I, 3)), Chr(2))
Err.Clear
coll.Add txt, txt
If Err.Number <> 0 Then coll.Remove txt
Next I
ReDim arr3(1 To coll.Count, 1 To 3)
For I = 1 To coll.Count
x = Split(coll(I), Chr(2))
For ii = 0 To 2
arr3(I, ii + 1) = x(ii)
Next
Next I
Worksheets("test").Range("A2").Resize(UBound(arr3, 1), 3).Value = arr3
Columns("A:C").EntireColumn.AutoFit
End Sub
Regards,
Timonek
Extract Duplicates
If you set CountSameWorksheetDuplicates to True, it will return the duplicates of each worksheet even if they are not found in the other worksheet.
Option Explicit
Sub ExtractDuplicates()
Const sName1 As String = "Sheet1"
Const sCols1 As String = "A:C"
Const sfRow1 As Long = 2
Const sName2 As String = "Sheet2"
Const sCols2 As String = "A:C"
Const sfRow2 As Long = 2
Const dName As String = "Test"
Const dfCellAddress As String = "A2"
Const CountSameWorksheetDuplicates As Boolean = False
Dim Delimiter As String: Delimiter = Chr(2)
Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
Dim sData As Variant
sData = RefColumns(wb.Worksheets(sName1).Rows(sfRow1).Columns(sCols1))
Dim cCount As Long: cCount = UBound(sData, 2)
Dim dict As Object: Set dict = CreateObject("Scripting.Dictionary")
dict.CompareMode = vbTextCompare
Dim r As Long
Dim sKey As Variant
For r = 1 To UBound(sData, 1)
sKey = StrJoinedDataRow(sData, r, Delimiter)
If CountSameWorksheetDuplicates Then
DictAddCount dict, sKey
Else
DictAdd dict, sKey, 1
End If
Next r
sData = RefColumns(wb.Worksheets(sName2).Rows(sfRow2).Columns(sCols2))
If CountSameWorksheetDuplicates Then
For r = 1 To UBound(sData, 1)
sKey = StrJoinedDataRow(sData, r, Delimiter)
DictAddCount dict, sKey
Next r
Else
Dim dict2 As Object: Set dict2 = CreateObject("Scripting.Dictionary")
dict2.CompareMode = vbTextCompare
For r = 1 To UBound(sData, 1)
sKey = StrJoinedDataRow(sData, r, Delimiter)
DictAdd dict2, sKey
Next r
For Each sKey In dict2.Keys
DictAddCount dict, sKey
Next sKey
Set dict2 = Nothing
End If
Erase sData
For Each sKey In dict.Keys
If dict(sKey) = 1 Then dict.Remove sKey
Next sKey
Dim drCount As Long: drCount = dict.Count
If drCount = 0 Then Exit Sub
Dim dData As Variant: ReDim dData(1 To drCount, 1 To cCount)
r = 0
Dim c As Long
For Each sKey In dict.Keys
sData = Split(sKey, Delimiter)
r = r + 1
For c = 1 To cCount
dData(r, c) = sData(c - 1)
Next c
Next sKey
Dim drg As Range
Set drg = wb.Worksheets(dName).Range(dfCellAddress).Resize(drCount, cCount)
drg.Value = dData
drg.Resize(drg.Worksheet.Rows.Count - drg.Row - drCount + 1) _
.Offset(drCount).Clear ' clear below
drg.EntireColumn.AutoFit
End Sub
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Purpose: Creates a reference to the range from the first row of a range
' ('FirstRowRange') to the row range containing
' the bottom-most non-empty cell in the row's columns.
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Function RefColumns( _
ByVal FirstRowRange As Range) _
As Range
If FirstRowRange Is Nothing Then Exit Function
With FirstRowRange.Rows(1)
Dim lCell As Range
Set lCell = .Resize(.Worksheet.Rows.Count - .Row + 1) _
.Find("*", , xlFormulas, , xlByRows, xlPrevious)
If lCell Is Nothing Then Exit Function ' empty range
Set RefColumns = .Resize(lCell.Row - .Row + 1)
End With
End Function
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Purpose: Returns the values of a row of a 2D array in a delimited string.
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Function StrJoinedDataRow( _
ByVal Data As Variant, _
ByVal RowIndex As Long, _
Optional ByVal Delimiter As String = " ") _
As String
Const ProcName As String = "StrJoinedDataRow"
On Error GoTo ClearError
Dim c As Long
Dim cString As String
For c = LBound(Data, 2) To UBound(Data, 2)
cString = cString & CStr(Data(RowIndex, c)) & Delimiter
Next c
StrJoinedDataRow = Left(cString, Len(cString) - Len(Delimiter))
ProcExit:
Exit Function
ClearError:
Debug.Print "'" & ProcName & "' Run-time error '" _
& Err.Number & "':" & vbLf & " " & Err.Description
Resume ProcExit
End Function
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Purpose: Adds a value ('Key') to a key of an existing ('ByRef')
' dictionary ('dict') adding another value ('Item')
' to the key's associated item.
' Remarks: Error and blank values are excluded.
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Sub DictAdd( _
ByRef dict As Object, _
ByVal Key As Variant, _
Optional ByVal Item As Variant = Empty)
If Not IsError(Key) Then
If Len(Key) > 0 Then
dict(Key) = Item
End If
End If
End Sub
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Purpose: Adds a value ('Key') to a key of an existing ('ByRef')
' dictionary ('dict') increasing its count being held
' in the key's associated item.
' Remarks: Error and blank values are excluded.
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Sub DictAddCount( _
ByRef dict As Object, _
ByVal Key As Variant)
If Not IsError(Key) Then
If Len(Key) > 0 Then
dict(Key) = dict(Key) + 1
End If
End If
End Sub
Dim Dict as Object
Dict = CreateObject("Scripting.Dictionary")
Dim Line As Object
For Each line in MyArray
On Error Resume Next
Dict.Add(Line, "")
On Error Goto 0
Next
Dictionaries don't allow duplicate keys. We are only setting keys and ignoring the value by not setting it. The dictionary raises an error if the key exists.
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
I want to check if each particular value (text&numbers) from a range 1 exists in range 2. If not, this value has to be added to the range 2.
For Each loop takes too much time. I want to try with arrays:
create an array with all values from range 1
create an array with all values from range 2
check if the element of array 1 is not empty
3.1 if not, check if the element exists in array 2
3.1.1 if yes, go to next element of array 1
3.1.2 if no:
3.1.2.1 add the element to array 2
3.1.2.1 add the element to the range 2 (in workbook)
3.2 if yes, go to next element of array 1
go to next element of array 1 and repeat third step
Public Sub Table_And_Layout()
Dim wsRoadmap As Worksheet
Dim wsBacklog As Worksheet
Dim bList As Range
Dim Arr() As Variant
Dim rListLastCol As Long
Dim TempRng As Variant
Dim element As Variant 'Range
Set wsBacklog = Sheets("Backlog")
Set wsRoadmap = Sheets("Roadmap")
Set bList = wsBacklog.Range("C7", wsBacklog.Cells(bListLast, 3))
bListLast = wsBacklog.Cells(wsBacklog.Rows.Count, "C").End(xlUp).Row
Arr = wsRoadmap.Range("C6", wsRoadmap.Cells(rListLastRow, rListLastCol))
For Each element In Arr
If Not IsEmpty(element) Then
Set TempRng = bList.Find(element.Value)
If TempRng Is Nothing Then
wsBacklog.Cells(bListLast + 1, 3).Value = wsRoadmap.Cells(element.Row, element.Column).Value
bListLast = wsBacklog.Cells(wsBacklog.Rows.Count, "C").End(xlUp).Row
End If
End If
Next element
End Sub
The OPTION 2 is the fastst one:
Public Sub Table_And_Layout()
Dim wsRoadmap As Worksheet
Dim wsBacklog As Worksheet
Dim bList As Range
Dim bListLast As Long
Dim rList As Range
Dim rListLastCol As Long
Dim TempRng As Variant
Dim element As Variant
'****************************
Dim StartTime As Double
Dim SecondsElapsed As Double
StartTime = Timer
'****************************
'Remember time when macro starts
StartTime = Timer
Set wsBacklog = Sheets("Backlog")
Set wsRoadmap = Sheets("Roadmap")
' unlock sheet
wsBacklog.Unprotect
bListLast = wsBacklog.Cells(wsBacklog.Rows.Count, "C").End(xlUp).Row
Set bList = wsBacklog.Range("C7", wsBacklog.Cells(bListLast, 3))
Set rList = wsRoadmap.Range("C6:BB100")
' find last not empty column
rListLastCol = wsRoadmap.Cells.Find(What:="*", _
After:=Range("A1"), _
LookAt:=xlPart, _
LookIn:=xlFormulas, _
SearchOrder:=xlByColumns, _
SearchDirection:=xlPrevious, _
MatchCase:=False).Column
'MsgBox "Last Col: " & rListLastCol
' find last not empty row
rListLastRow = wsRoadmap.Cells.Find(What:="*", _
After:=Range("A1"), _
LookAt:=xlPart, _
LookIn:=xlFormulas, _
SearchOrder:=xlByRows, _
SearchDirection:=xlPrevious, _
MatchCase:=False).Row
'MsgBox "Last Row: " & rListLastRow
Set rList = wsRoadmap.Range("C6", wsRoadmap.Cells(rListLastRow, rListLastCol))
'MsgBox rList.Address
'OPTION 1 (works but very slow)
' ' filling backlog
' For Each element In rList
' If Not element Is Nothing Then
' Set TempRng = bList.Find(element.Value)
' If TempRng Is Nothing Then
' wsBacklog.Cells(bListLast + 1, 3).Value = wsRoadmap.Cells(element.Row, element.Column).Value
' bListLast = wsBacklog.Cells(wsBacklog.Rows.Count, "C").End(xlUp).Row
' End If
' End If
' Next element
'OPTION 2 (works fast)
' declare array for roadmap
Dim Arr() As Variant ' declare an unallocated array.
Arr = wsRoadmap.Range("C6", wsRoadmap.Cells(rListLastRow, rListLastCol)) ' Arr is now an allocated array
' Dim NumRows As Long
' Dim NumCols As Long
' MsgBox NumRows = UBound(Arr, 1) - LBound(Arr, 1) + 1
' MsgBox NumCols = UBound(Arr, 2) - LBound(Arr, 2) + 1
' declare array for backlog
Dim ArrB() As Variant
ArrB = wsBacklog.Range("C6", wsBacklog.Cells(bListLast, 3))
'filling backloga
For Each element In Arr
If Not IsEmpty(element) Then
Set TempRng = bList.Find(element)
If TempRng Is Nothing Then
wsBacklog.Cells(bListLast + 1, 3).Value = element
bListLast = wsBacklog.Cells(wsBacklog.Rows.Count, "C").End(xlUp).Row
End If
End If
Next element
'OPTION 3 (does not work)
' For i = LBound(Arr) To UBound(Arr)
' For j = LBound(ArrB) To UBound(ArrB)
' If Not IsEmpty(i) Then
' If Arr(i) = ArrB(j) Then
' wsBacklog.Cells(bListLast + 1, 3).Value = Arr(i)
' End If
' End If
' Next
' Next
'*************************************************************************************
'Determine how many seconds code took to run
SecondsElapsed = Round(Timer - StartTime, 2)
'Notify user in seconds
MsgBox "This code ran successfully in " & SecondsElapsed & " seconds", vbInformation
'*************************************************************************************
End Sub
PS. Thank you SJR!
I have a for next loop that runs through a couple hundred thousand lines making changes on most. Could an array to make this code run faster?
The example of my for loop. Sometimes it gets overloaded and crashes Excel. (FYI my loop has to run bottom to top for it to do its intended purpose.)
Sub RemoveDuplicates()
Dim shWorkBook As Worksheet
Dim wkb As Workbook
Dim FullYearData As Worksheet
Set wkb = ThisWorkbook
With wkb
Set shWorkBook = .Sheets("Workbook")
Set shFullYearData = .Sheets("FullYearData")
End With
Dim i As Long
Dim LastRowW As Long
On Error Resume Next
Call TurnOffCalc
FirstRowW = shWorkBook.Cells(1, 1).Row
FirstColW = shWorkBook.Cells(1, 1).Column
LastRowW = shWorkBook.Cells(Rows.Count, 1).End(xlUp).Row
LastColW = shWorkBook.Cells(2, Columns.Count).End(xlToLeft).Column
i = LastRowW
Sum = 0
shWorkBook.Activate
For i = LastRowW To 1 Step -1
If shWorkBook.Cells(i, 7) = shWorkBook.Cells(i - 1, 7) Then
shWorkBook.Cells(i, 26) = vbNullString
End If
If shWorkBook.Cells(i, 26).Value <> "" Then
shWorkBook.Cells(i, 27) = Sum + Cells(i, 25).Value
Sum = 0
ElseIf shWorkBook.Cells(i, 26).Value = "" Then
Sum = shWorkBook.Cells(i, 25).Value + Sum
End If
Next
p = FirstRowW + 1
For p = FirstRowW + 1 To LastRowW Step 1
shWorkBook.Cells(p, 28) = Application.WeekNum(shWorkBook.Cells(p, 3))
Next
shWorkBook.Cells(1, 28).Value = "Week Number"
Call TurnOnCalc
End Sub
Try something like this:
Sub RemoveDuplicates()
Dim shWorkBook As Worksheet
Dim wkb As Workbook
Dim FullYearData As Worksheet
Dim i As Long, Sum
Dim LastRowW As Long, LastColW As Long, tbl As Range, data
Set wkb = ThisWorkbook
With wkb
Set shWorkBook = .Sheets("Workbook")
'Set shFullYearData = .Sheets("FullYearData")
End With
LastRowW = shWorkBook.Cells(Rows.Count, 1).End(xlUp).Row
LastColW = shWorkBook.Cells(2, Columns.Count).End(xlToLeft).Column
Set tbl = shWorkBook.Range("A1").Resize(LastRowW, 28) 'include "Week number" (?)
data = tbl.Value 'get the range value as an array
data(1, 28) = "Week Number"
Sum = 0
For i = LastRowW To 1 Step -1
If data(i, 7) = data(i - 1, 7) Then data(i, 26) = vbNullString
If data(i, 26).Value <> "" Then
data(i, 27) = Sum + data(i, 25).Value
Sum = 0
Else
Sum = data(i, 25).Value + Sum
End If
If i > 1 Then data(i, 28) = CLng(Format(data(i, 3), "ww"))
Next
tbl.Value = data 'return the data
End Sub