VBA Macro to find rows and store in array runs slow - excel

So I made a simple VBA macro to run over ~7000 rows of data - the idea is that .Find finds the cells which contain "1" in column G, so that it can store the row number in an array which I shall later throw back to another sub
Unfortunately the code takes too long to run - it begs the question, have I created an infinite loop in my code? Or is asking it to loop a .find operation over 7000 cells too much for vba to handle at a reasonable speed? (i.e. do I need to improve efficiency in areas?)
Option Explicit
Public Sub splittest()
Dim sheet As Object, wb As Workbook
Dim rangeofvals As Range
Dim pullrange As Variant
Dim c As Long
Dim dynarr() As Variant
Dim xvalue As Long
Dim firstaddress As Variant
Dim count As Long
Set wb = ThisWorkbook
Set sheet = wb.Sheets("imported d")
Set rangeofvals = Range("G1:G6939")
'need to set pull range at some later point
Call OptimizeCode_Begin 'sub which turns off processes like application screen updating
xvalue = 1
ReDim dynarr(3477) 'hardcoded, replace with a countif function at some point
count = 0
With wb.Sheets("imported d").Range("G1:G6939")
c = rangeofvals.Find(xvalue, LookIn:=xlFormulas).Row
If c >= 0 Then
dynarr(count) = c
' MsgBox firstaddress
Do
' MsgBox c
c = rangeofvals.FindNext(Cells(c, 7)).Row
dynarr(count) = c 'apparently redim preserve would be slower
Loop While c >= 0
End If
Call OptimizeCode_End 'sub which turns back on processes switched off before
End With
End Sub

If you know the column is G and all the data is contiguous, then just loop through the rows and check the cell value directly:
Dim rows As New Collection
Dim sheet As Worksheet
Dim lastRow, i As Integer
Set sheet = ThisWorkbook.Sheets("imported d")
lastRow = sheet.Cells(1,7).CurrentRegion.Rows.Count
For i = 1 to lastRow
If (sheet.Cells(i,7).Value = 1) Then
rows.Add i
End If
Next
Unclear how the data is being used in the other sub but collection is definitely more efficient storage object for adding iteratively when the total item count is indeterminate. If you want to convert to an array then you can do so efficiently afterward since the collection tells you the item count. I'm not really sure why you would need an array specifically but I'm not going to tell you not to without seeing the client sub. Also note that the declaration of sheet was changed from Object to Worksheet since it is better to use the specific data type if possible.

...yep it was an infinite loop.
the line:
Loop While c >= 0
caused it as there is never an occasion c is less than 0 - back to the drawing board for me!

Related

copy paste range after search

I inherited a report that acts as a master tracker for changes made in several other reports. The previous owner was using VLOOKUP formulas to pull data, however I decided to try my hand at a VBA macro and was able to patchwork something together (see below) despite being new to this. It works fine, however:
Problem 1: Right now, the macro returns values one column at a time. I have four nearly identical sub procedures that run back-to-back, one per column: Updated_LName (N), New_Doc (O), New_ID (P), Comments (Q).
Desired Solution: I'd like to increase efficiency by searching for the Student_ID_Nbr (K) in the previous worksheet and then returning values for all four columns at once: Updated_LName, New_Doc, New_ID, Comments (N:Q).
Problem 2: I couldn't figure out a better way than clearing formatting to skip to the next Student_ID_Nbr if it's not found on the previous page. I don't want to overwrite any existing values, which is why I didn't assign an empty string value in the If/Else statement.
Desired Solution: Find a better way to skip to the next iteration if Student_ID_Nbr is not found in the previous worksheet without overwriting existing data.
Problem 3: The macro currently ignores records where there is no Student_ID_Nbr match between the master and the previous worksheet. All changes must be extracted from the other reports and reflected in the master worksheet.
Desired Solution: I'd like to paste in the entire row (A:Q) for each record where the Updated_LName (N), New_Doc (O), New_ID (P), AND/OR Comments (Q) are not blank, AND the Student_ID_Nbr is not present in the master worksheet.
Note: Assume Student_ID_Nbr is a primary key.
Screenshot of example worksheets/data, after running macro successfully
K
L
M
N
O
P
Q
1
Imported
Imported
Imported
Imported
2
Student_ID_Nbr
Qty
LName
Updated_LName
New_Doc
New_ID
Comments
3
123456789
1
Doe
Smith
Transcript
987654321
Marriage cert submitted
Public Sub PullUpdated_LName()
'Declarations
Dim varID As Variant
Dim wsCurrent As Worksheet
Dim wsPrevious As Worksheet
Dim rngSelection As Range
Dim i As Integer
For i = 3 To 30000
'Initialization
Set wsCurrent = ActiveSheet
Set wsPrevious = wsCurrent.Previous
Set rngSelection = ActiveCell
'Error checking--do nothing if not in the correct column
If Not rngSelection.Column = 14 Then
MsgBox "Please select a cell in column N.", vbCritical + vbOKOnly, "Error"
Exit Sub
End If
'Search for ID on the previous ws
Set varID = wsPrevious.Columns(11).Find(What:=wsCurrent.Cells(rngSelection.Row, 11).Value)
'If ID not found, leave existing values alone (including empty cells) on current sheet
If varID Is Nothing Then
rngSelection.ClearFormats
Else
'Return the value in the appropriate row and column from the previous sheet
rngSelection.Value = wsPrevious.Cells(varID.Row, 14).Value
End If
'Regardless, move to the next cell
wsCurrent.Cells(rngSelection.Row + 1, rngSelection.Column).Select
Next i
'Move to next column (to prepare for the next sub)
wsCurrent.Cells(3, rngSelection.Column + 1).Select
'Run next sub automatically
PullNew_Doc
End Sub
Thank you to ShawnPCooke for the great starting point.
You seem to be re-initializing the worksheets each time around the loop, and the limit of 30000 rows to search seems arbitrary and will likely be slow while that searches empty space. Any time you "Select" a cell, you will potentially have the view updating; best to keep everything in Range variables.
This code probably addresses your first two points:
Public Sub Pull_All()
'Declarations
Dim varID As Variant
Dim wsCurrent As Worksheet
Dim wsPrevious As Worksheet
Dim rngSelection As Range
Dim i As Integer
Dim search_zone As Range
Dim last_row As Long
Dim update_cols As Variant
Dim ref_row As Long
Dim ref_col As Long
Dim col As Variant
update_cols = Array(14, 15, 16, 17)
ref_row = 3
ref_col = 11
'Initialize sheets
Set wsCurrent = ActiveSheet
Set wsPrevious = wsCurrent.Previous
Set search_zone = wsPrevious.Columns(11)
' start on a defined cell in the worksheet; this may need update
Set rngSelection = wsCurrent.Cells(ref_row, ref_col)
last_row = rngSelection.SpecialCells(xlCellTypeLastCell).Row
For i = ref_row To last_row
' Search for ID on the previous ws
Set varID = search_zone.Find(What:=rngSelection.Value)
If Not varID Is Nothing Then
' Return the values in the appropriate row and update columns from the previous sheet
For Each col In update_cols
rngSelection.Offset(0, col - ref_col).Value = wsPrevious.Cells(varID.Row, col).Value
Next col
End If
' move to the next cell
Set rngSelection = rngSelection.Offset(1, 0)
Next i
End Sub

VBA Function to find Activecell Table Row

As a learning exercise & possible use in future code I have created my first Excel VBA function to return the activecell row number in any Excel Table (as opposed to the sheet itself) . Essentially it simply finds the active row in the sheet, then finds the row number of the table header which is then subtracted from the cell row number to return the row number of the table which can then be used in subsequent code. However, while it works, it dosen't look the most efficient Can anyone improve it?
Sub TableRow()
Dim LORow As Integer
Dim TbleCell As Range
Set TbleCell = Activecell
Call FuncTableRow(TbleCell, LORow)
MsgBox LORow
End Sub
Public Function FuncTableRow(ByRef TbleCell As Range, LORow As Integer) As Range
Dim LOName As String
Dim LOHeaderRow, Row As Integer
LOName = Activecell.ListObject.Name
Row = Activecell.Row
LOHeaderRow = ActiveSheet.ListObjects(LOName).HeaderRowRange.Row
LORow = Row - LOHeaderRow
Debug.Print (LORow)
End Function
This question will probably get closed for not being specific enough but the most obvious item (to me) is your usage of a custom function. Your function is not actually returning anything, it's only running a debug print. To have your function actually return the row number, you would set it as a type Long (not integer) and include the function name = to the number.
I didn't actually test your function but assuming LORow is dubug printing the proper answer then it should work like this:
Public Function FuncTableRow(ByRef TbleCell As Range, LORow As Integer) As Long
Dim LOName As String
Dim LOHeaderRow, Row As Integer
LOName = Activecell.ListObject.Name
Row = Activecell.Row
LOHeaderRow = ActiveSheet.ListObjects(LOName).HeaderRowRange.Row
LORow = Row - LOHeaderRow
Debug.Print (LORow)
FuncTableRow = LORow
End Function
You also don't Call a function, you can just insert it as itself in a subroutine.
You are using LORow as an input variable but then changing it. That's typically a bad practice.
You should not be using ActiveSheet grab the worksheet from TbleCell.Worksheet
You would almost never use activecell as part of a Custom Formula.
Dim LOHeaderRow, Row As Integer should actually be Dim LOHeaderRow as Long, Row As Long. As you currently have it LOHeaderRow is undefined/Variant.
There's probably more. I would restart your process with a simpler task of returning the last used cell in a worksheet. There's a dozen ways to do this and lots of help examples.
Take a look at this TheSpreadsheetGuru.
Here are some variables that might help you.
Sub TableVariables()
Dim ol As ListObject: Set ol = ActiveSheet.ListObjects(1)
Dim olRng As Range: Set olRng = ol.Range ' table absolute address
Dim olRngStr As String: olRngStr = ol.Range.Address(False, False) ' table address without absolute reference '$'
Dim olRow As Integer: olRow = ol.Range.Row ' first row position
Dim olCol As Integer: olCol = ol.Range.Column ' first column position
Dim olRows As Long: olRows = ol.Range.Rows.Count ' table rows including header
Dim olCols As Long: olCols = ol.ListColumns.Count ' table columns
Dim olListRows As Long: olListRows = ol.ListRows.Count ' table rows without header
End Sub

Load Values From Closed Workbook Into Array

I have not used VBA in a while so I'm a bit rusty. Seeking help.
The task:
I need to pull all unique value from a given range in a closed workbook, into my sub's workbook.
I'm thinking of calling a function that returns an array of my unique non-blank values. because I need to know the quantity of unique values to insert the right amount of lines in the main workbook. Can't juts copy-paste the values. And also because I need to remove the duplicates.
Some relevant code bits up to know:
Sub PullACParts()
Dim FullFilePath As String
Dim arrPartList() As String
FullFilePath = "C:\Users\[...]file1.xlsx"
arrPartList() = GetValues(FullFilePath)
and that calls:
Function GetValues(path as string) as Variant
Dim arrValues() As String
Dim arrUnikVals As String
On Error GoTo ErrHandler
Application.ScreenUpdating = False
Dim src As Workbook
' OPEN THE SOURCE EXCEL WORKBOOK IN "READ ONLY MODE".
Set src = Workbooks.Open(FullFilePath, True, True)
' GET THE TOTAL ROWS FROM THE SOURCE WORKBOOK.
Dim iTotalRows As Integer
TotalRows = src.Worksheets("Sheet1").Range("D1:D" & Cells(Rows.Count, "D").End(xlUp).Row).Rows.Count
' COPY NON-BLANK DATA FROM SOURCE FILE COLUMN-4 TO ARRAY.
Dim iCnt As Integer ' COUNTER.
Dim ArrDim As Long: ArrDim = 0
For iCnt = 4 To TotalRows
If src.Worksheets("Sheet1").Range("D" & iCnt).Value <> "" Then
arrValues(ArrDim) = src.Worksheets("Sheet1").Cells(4 & iCnt).Formula 'FAILS HERE
ArrDim = ArrDim + 1
End If
Next iCnt
' CLOSE THE SOURCE FILE.
src.Close False ' FALSE - DON'T SAVE THE SOURCE FILE.
Set src = Nothing
' Remove Duplicates
arrUnikVals = RemoveDupesColl(arrValues)
GetValues = arrUnikVals
ErrHandler:
Application.EnableEvents = True
Application.ScreenUpdating = True
End Function
It fails when I try loading the array. Says "arrValues(ArrDim) =
I tried a few different things but just can't figure it out.
Thanks in advance for the help!!
You don't need to loop this. First set your variable types.
Dim arrValue as Variant, lr as long
Once this is a variant you can simply grab the array from the range in one go by transposing it:
lr = src.Worksheets("Sheet1").range("D" & rows.count).end(xlup).row
Application.transpose(src.Worksheets("Sheet1").range("D4:D" & lr))
If you need to loop the values in the array later you simply do something like this:
Dim X as long
For X = lbound(arrValue) to ubound(arrValue)
msgbox arrValue(X)
next
I do however note in your question you say you want to pull data from a CLOSED workbook but your code is opening the book. There are ways to pull data direct from a closed book but it would be difficult because you don't know how many rows it will be without opening the book. If you absolutely have to leave the book closed then post back.
I also note you are using cells(4 & iCnt) to try and populate the array, you do know that is just the cell counting from left to right then row to row? in other words cells(2) is B1 and cells(16386) is B2. You should use cells(Row,Column) I think from what you have said you want to increment the row but if not then post back, we simply double transpose if it's across columns instead of rows.

VBA Copying data from one table to another and rearranging columns

I have 99 columns in one table called tbl_raw. I need to copy 96 of those columns into another table with the same exact header names, but they are rearranged in a different order. What is the most efficient way to do this?
The only way I knew was:
raw_data.Range("tbl_raw[EMPLOYEE]").Copy
processed_data.Range("tbl_processed[EMPLOYEE]").PasteSpecial
However, this would take a lot of code (96 * 2 = 192 lines) and I wasn't sure if there was a more efficient way to do it.
I tried to use https://www.thespreadsheetguru.com/blog/2014/6/20/the-vba-guide-to-listobject-excel-tables, but I couldn't figure out a way to do it with that information either.
Any guidance would be greatly appreciated.
Avoid dealing with copying ListObject columns and use a direct value transfer.
Option Explicit
Sub raw2processed()
Dim lc As Long, mc As Variant, x As Variant
Dim raw_data As Worksheet, processed_data As Worksheet
Dim raw_tbl As ListObject, processed_tbl As ListObject
Set raw_data = Worksheets("raw")
Set processed_data = Worksheets("processed")
Set raw_tbl = raw_data.ListObjects("tbl_raw")
Set processed_tbl = processed_data.ListObjects("tbl_processed")
With processed_tbl
'clear target table
On Error Resume Next
.DataBodyRange.Clear
.Resize .Range.Resize(raw_tbl.ListRows.Count + 1, .ListColumns.Count)
On Error GoTo 0
'loop through target header and collect columns from raw_tbl
For lc = 1 To .ListColumns.Count
Debug.Print .HeaderRowRange(lc)
mc = Application.Match(.HeaderRowRange(lc), raw_tbl.HeaderRowRange, 0)
If Not IsError(mc) Then
x = raw_tbl.ListColumns(mc).DataBodyRange.Value
.ListColumns(lc).DataBodyRange = x
End If
Next lc
End With
End Sub
Here's a basic example of copying over all but some columns from one table to another:
Dim tbl1 As ListObject, tbl2 As ListObject
Dim h As ListColumn
Set tbl1 = ActiveSheet.ListObjects("Table1")
Set tbl2 = ActiveSheet.ListObjects("Table2")
'loop over the headers from the source table
For Each h In tbl1.ListColumns
'is the column name in the "excluded" list?
If IsError(Application.Match(h.Name, Array("col10", "col11"), 0)) Then
'ok to copy...
h.DataBodyRange.Copy tbl2.ListColumns(h.Name).DataBodyRange(1)
End If
Next h
ForEach/For are the magic of working with arrays and collections.
There are ways to make the following code more efficient, but I think that may get in the way of understanding what is happening.
It has been about 6 months or so since I last worked with VBA, but I believe this should work. I suggest stepping through and watching your locals to see what is going on. If there are issues with variable assignments, there might need to be a 'Let' changed to a 'Set'.
Code follows:
'// PROBLEM:
'// Copy data from one list to a second list.
'// Both lists have the same column names and the same number of columns.
'// Copy data based on the column name.
'// Modify to return a custom source-destination association.
Private Function GetColumnTranslations(zLeftColumns As ListColumns, zRightColumns As ListColumns) As Variant
Dim zReturn(,) As Variant
ReDim zReturn(0 To zLeftColumns.Count As Long, 0 To 1 As Long)
Dim zReturnOffset As Long '// Specifies what index we are working at during our ForEach interations.
Dim zLeftVar As Variant
Dim zRightVar As Variant
ForEach zLeftVar in zLeftColumns
'// Go through each 'left' column to Find the first 'right' column that matches the name of the 'left' column.
'// Only the first 'right' column with a matching name will be used. Issue is solved with another ForEach, but beyond forum question's scope.
ForEach zRightVar in zRightColumns
If zLeftVar.Name = zRightVar.Name Then
'// Store the association and exit the nested ForEach.
Let zReturn(zReturnOffset, 0) = zLeftVar.Range.Column '// Source.
Let zReturn(zReturnOffset, 1) = zRightVar.Range.Column '// Destination.
Let zReturnOffset = zReturnOffset + 1
Exit ForEach
End If
Next zRightVar
Next zLeftVar
'// Assign return value.
Let GetColumnTranslations = zReturn
End Function
'// Take each source row and copy the value to a new destination row.
'// New rows are added to the end of the destination list.
Public Sub CopyList(zSourceList As ListObject, zDestinationList As ListObject)
Dim zColumnTranslations As Variant '// Will be 2-dimensional array.
Dim zTranslationVar As Variant '// Will be array of 2 elements.
Let zColumnTranslations = GetColumnTranslations(zSourceList.Columns, zDestinationList.Columns)
Dim zSourceRowVar As Variant '// Will translate to Range.
Dim zDestinationRow As Range
'// Every source row needs copied to a new row in destination.
ForEach zSourceRowVar in zSourceList.Rows
Set zDestinationRow = zDestinationList.Rows.Add.Range
ForEach zTranslationVar in zColumnTranslations
'// Value may copy formula.
Let zDestinationRow(0,zTranslationVar(1)).Value = zSourceRowVar(0,zTranslationVar(0)).Value
Next zTranslationVar
Next zSourceRowVar
End Sub

Check to see if a value is present, then copy to another worksheet

I'm trying to take a rough list of data, then copy it into a pre-formatted, organized form. To do this, I have the rough list set up so that each item on the list is numbered in order, no matter if there are spaces between items. The macro I am trying to make will take that rough list and copy it to the form without any spaces. Bear with me, I have been trying to teach myself Visual Basic, so the code I have may be... messy. Currently, the problem that I am having is that I get an overflow on i = i + 1.
Sub Print_Sheet_Populate()
'
' Print_Sheet_Populate Macro
' Takes Items from Raw Data sheet and puts them in Print Sheet sheet.
'
'
Dim wsS1 As Worksheet
Dim wsS2 As Worksheet
Dim ending As Long
Dim copy() As Long
Dim i As Long
Set wsS1 = Sheets("Raw Data")
Set wsS2 = Sheets("Print Sheet")
With wsS1.Range("A:A") 'To copy the item numbers in the rough data to an array
i = 1
Set c = .Find(i, LookIn:=xlValues)
If Not c Is Nothing Then
ReDim copy(i)
copy(i - 1) = c.Value
Do
i = i + 1
ending = i
Loop While Not c Is Nothing
End If
End With
With wsS2.Range("A24:A324") 'To paste the data from the array to the form
i = 1
If Not i = ending Then
Do
Worksheets("wsS2").Range("A" & i).Value = copy(i - 1)
i = i + 1
Loop While Not c Is Nothing
End If
End With
End Sub
Taken from Range.Find Method (Excel):
When the search reaches the end of the specified search range, it
wraps around to the beginning of the range. To stop a search when this
wraparound occurs, save the address of the first found cell, and then
test each successive found-cell address against this saved address.

Resources