I'm writing a simple Excel VBA program to search through the entire client database, looking for the specific record. While doing this, I've encountered a problem - after encountering first match, it does the instructions well and stops.
The database consists of 500+ rows and looks like this:
Column A Column B Column C Column D
Name xxxx yyy zzzz
Here's some simplified code
Sub Analizuj_1_Click()
Dim SearchName As String
Dim CColumn As Integer
Dim Match As Boolean
Dim CRow As Integer
Dim CRowPaste As Integer
On Error GoTo Err_Execute
LDate = Range("NazwaKlienta").Value
Sheets("2019").Select
'Starting in Column A, Row 2'
LColumn = 1
LRow = 2
LRowPaste = 2
LFound = False
While LFound = False
'Found a blank cell -> terminate'
If Len(Cells(CRow, 1)) = 0 Then
MsgBox "Klient nie ma zaległości"
Exit Sub
'Found Match
Szukaj: ElseIf Cells(CRow, 1) = SearchName Then
Cells(CRow, 1).EntireRow.Select
Selection.Copy
Sheets("test").Select
Cells(CRowPaste, 1).Select
Selection.PasteSpecial Paste:=xlValues, Operation:=xlNone, SkipBlanks:= _
False, Transpose:=False
LFound = True
CRowPaste = CRowPaste + 1
Sheets("2019").Select
'Continuation"
ElseIf Cells(CRow, 1).Value > 0 Then
CRow = CRow + 1
GoTo Szukaj
End If
Wend
Exit Sub
Err_Execute:
MsgBox "Blad."
End Sub
Even If I try to continue searching through Start statement, it stops at the first found match. I tried to experiment with other methods and still the same problem.
Inb4 I know, selecting is not the most efficient method for anything
Related
I delete rows based on the date in a column.
The dataset is around 85,000 rows and the macro can take from 30s to 5m+ with constant freezing.
I'm not sure if this is due to poorly written code or the size of the dataset.
Sub DeleteCurrentPeriod()
Dim ws As Worksheet
Application.ScreenUpdating = False
Set ws = ThisWorkbook.Worksheets("Transaction list by date")
ws.Activate
On Error Resume Next
ws.ShowAllData
On Error GoTo 0
'Insert column, autofill formula for range
Sheets("Transaction list by date").Select
Columns("AR:AR").Select
Selection.Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
Range("AR2").Select
ActiveCell.FormulaR1C1 = "=IFERROR(IF(RC[-1]>CONTROL!R20C7,""Y"",""""),"""")"
Selection.AutoFill Destination:=Range("AR2:AR100000"), Type:=xlFillDefault
'Filter on new column for cells matching criteria
ws.Range("$A$1:$BE$100000").AutoFilter Field:=44, Criteria1:="Y"
'Delete rows with matching criteria
On Error Resume Next
Application.DisplayAlerts = False
ws.Range("$A$2:$BE$100000").SpecialCells(xlCellTypeVisible).Delete
Application.DisplayAlerts = True
On Error GoTo 0
'Delete added column and remove filter
Columns("AR:AR").Select
Selection.Delete Shift:=xlToLeft
On Error Resume Next
ws.ShowAllData
On Error GoTo 0
Application.ScreenUpdating = True
Application.Goto Reference:=Range("A1")
End Sub
You can give this a try (use F8 key to run it step by step)
Some suggestions:
Name your procedure and variables to something meaningful
Indent your code (you may use Rubberduckvba.com)
Split the logic in steps
Read about avoiding select and activate here
Code:
Public Sub DeleteCurrentPeriod()
On Error GoTo CleanFail
' Turn off stuff
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Dim transactionSheet As Worksheet
Set transactionSheet = ThisWorkbook.Worksheets("Transaction list by date")
' Turn off autofilter and show all data
transactionSheet.AutoFilterMode = False
' Find last row
Dim lastRow As Long
lastRow = transactionSheet.Cells(transactionSheet.Rows.Count, "AQ").End(xlUp).Row
' Define range to be filtered
Dim targetRange As Range
Set targetRange = transactionSheet.Range("A1:BE" & lastRow)
' Insert column
transactionSheet.Columns("AR:AR").Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
' Add formula & calculate
transactionSheet.Range("AR2:AR" & lastRow).FormulaR1C1 = "=IFERROR(IF(RC[-1]>CONTROL!R20C7,""Y"",""""),"""")"
Application.Calculate
'Filter on new column for cells matching criteria
transactionSheet.Range("A1:BE" & lastRow).AutoFilter Field:=44, Criteria1:="Y"
'Delete rows with matching criteria
transactionSheet.Range("A2:BE" & lastRow).SpecialCells(xlCellTypeVisible).EntireRow.Delete
'Delete added column and remove filter
transactionSheet.Columns("AR:AR").Delete Shift:=xlToLeft
' Remove filter
transactionSheet.AutoFilterMode = False
'Select A1
Range("A1").Select
CleanExit:
' Turn on stuff again
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
Exit Sub
CleanFail:
MsgBox "An error occurred:" & Err.Description
GoTo CleanExit
End Sub
Let me know if it works
I've just made a couple of changes to how you work out the last row and how you do the calculation, it looks like you were comparing to a constant on the Control sheet. I wonder though why are you adding a column in and then deleting it, could you not just perform the calcs in column +1 after your data? Then you wouldn't have to create and delete the column.
'Insert column, autofill formula for range
Dim x as Long, y, lastrow
Sheets("Transaction list by date").Select
'Find the last row used
With Sheets("Transaction list by date")
lastrow = .Range("A" & .Rows.Count).End(xlUp).Row
End With
Columns("AR:AR").Select
Selection.Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
Range("AR2").Select
' Get the constant and perform the comparison, add "Y" to TRUE cells
x= Worksheets("Control").Cells(20,7).value
For y = 1 to lastrow
If Worksheets("Transaction list by date").Cells(y,44)>x then _
Worksheets("Transaction list by date").Cells(y,44).value = "Y"
Next y
'Filter on new column for cells matching criteria
ws.Range("$A$1:$BE$" & lastrow ).AutoFilter Field:=44, Criteria1:="Y"
'Delete rows with matching criteria
On Error Resume Next
Application.DisplayAlerts = False
ws.Range("$A$2:$BE$" & lastrow).SpecialCells(xlCellTypeVisible).Delete
Application.DisplayAlerts = True
On Error GoTo 0
'Delete added column and remove filter
Columns("AR:AR").Select
Selection.Delete Shift:=xlToLeft
On Error Resume Next
ws.ShowAllData
On Error GoTo 0
Application.ScreenUpdating = True
Application.Goto Reference:=Range("A1")
End Sub
Sub RemoveDups()
Const COMPARE_COL As Long = 1
Dim a, aNew(), nr As Long, nc As Long
Dim r As Long, c As Long, rNew As Long
Dim v As String, tmp
a = Worksheets("Sheet1").UsedRange
nr = UBound(a, 1)
nc = UBound(a, 2)
ReDim aNew(1 To nr, 1 To nc)
rNew = 0
v = Date
For r = 1 To nr
tmp = a(r, COMPARE_COL)
If tmp <> v Then
rNew = rNew + 1
For c = 1 To nc
aNew(rNew, c) = a(r, c)
Next c
v = tmp
End If
Next r
Worksheets("Sheet1").UsedRange = aNew
End Sub
This is an answer written by Tim Williams I just set the range to used range and set v to Date, so if you copy and paste this it will search based on the current date you run the macro looking through column 1 (A) If you want to use a different date you'll have to redefine v, you can make that equal to the cell on your control sheet. Took 1 second to "delete" 85000 rows.
**Thanks all for the pointers on how to as well as the Code Review section. Today I switched over to pulling and comparing the numbers by making an array for each group of numbers. It works in seconds now rather than minutes. **
I have working code, it does the job just fine. It's purpose is to check and report if there are any duplicate loan numbers by comparing the ReadyForExport (normally about 60 rows) sheet to the PastLoanLog sheet (presently about 1300 rows) one by one.
Question: Any ideas on how to code this better? It takes a few minutes to run, but if there is a way I can make it run faster, that's what I am searching for. Here is the code:
Sub DupTest2()
'This runs through the RFE list, checks the 2nd mortgage numbers
'and reviews against the PastLoanLog spreadsheet
MsgBox ("This may take a minute")
OpenSheets 'Opens worksheets needed to run the program
Dim TestDpaNum As String
Dim PastDpaNum As String
Dim lRow As Integer
Dim DupNum As Integer
Dim h As Integer
Dim i As Integer
Dim lrowHFE As Integer
Sheets("ReadyForExport").Select
Range("G2").Select
lrowHFE = Cells(Rows.Count, 1).End(xlUp).Row
Debug.Print "Ready For Export LR " & lrowHFE
'Locate Last Row In PastLoanLog Data
'**********************************
Sheets("PastLoanLog").Select
Range("G2").Select
lRow = Cells(Rows.Count, 1).End(xlUp).Row
Sheets("ReadyForExport").Select
Range("G2").Select
For h = 2 To lrowHFE
'Finds the first loan number to check against the old data
TestDpaNum = ActiveCell.Value
Sheets("PastLoanLog").Select
Range("G2").Select
For i = 1 To lRow
'Selects current cell to compare with cell from RFE sheet
PastDpaNum = ActiveCell.Value
If PastDpaNum = TestDpaNum Then
DupNum = DupNum + 1
Debug.Print "Duplicate Found" & TestDpaNum
Sheets("ErrorSheet").Range(DupNum, 6).Value = TestDpaNum
ActiveCell.Offset(1, 0).Select
Else
ActiveCell.Offset(1, 0).Select
End If
Next
Sheets("ReadyForExport").Select
ActiveCell.Offset(1, 0).Select
Debug.Print "CurrentRow=" & h
Next
'Sends the info to the Dashboard
Debug.Print "Dups = " & DupNum
Sheets("Dashboard").Select
Range("P16").Select
ActiveCell.Value = DupNum
ActiveCell.Offset(1, 0).Value = Now()
CloseSheets
End Sub
Sequence of events which I am trying to achieve:
1) I have data on Sheet1
2) I filter the data on Sheet1 according to a certain criteria and then copy the data to another Sheet say "Difference". The data has around 8 lines.
3) I then insert 11 lines between the data on sheet "Difference" after every 2 lines.
4) Next I insert 4 columns before the first column
5) I then insert the column header for the first 4 inserted column and row headers till the UsedRange.
6) After that I am doing certain less intensive calculations on the data such as comparing the values and looking up data from another workbook.
All this is in a macro on click of a button.
While clicking the button what happens is that sometimes I get the rows and columns in a sequence as expected and actually most of the times after the first 4 columns the rows come in a zig zag manner i.e. sometimes they would comes 5 - 6 columns after the first 4 columns and on other runs of a macro the rows would come after 50 lines or so.
I investigated my code but couldn't find any reason why this is happening. Also this happens intermittently. As I mentioned sometimes the result comes fine and most of the times the result (rows and columns) come in a zig zag manner.
Why is macro doing this? I am really having a hard time thinking about it? I have no answer. It seems so illogical.
I could post my code but it's too big. Please let me know which portion of the code should I post.
Please do suggest. Having a really hard time.
I am posting my code snippet below:
Private Sub CommandButton1_Click()
Application.Calculation = xlCalculationManual
Application.ScreenUpdating = False
Application.DisplayStatusBar = False
Application.EnableEvents = False
ActiveSheet.DisplayPageBreaks = False
Dim wb As Workbook
Dim sh1 As Worksheet
Dim sh2 As Worksheet
Dim sh3 As Worksheet
Dim ws As Worksheet
Dim i As Long
Set wb = GetObject(ActiveWorkbook.Path & "\ReconUtility_Enhanced.xlsm")
Set sh1 = wb.Sheets("Sheet1")
Set sh2 = wb.Sheets("Sheet2")
MsgBox sh2.UsedRange.Rows.count
For i = 1 To sh2.UsedRange.Rows.count
sh1.Activate
ActiveSheet.UsedRange.Select
Selection.AutoFilter
sh1.Range("E1").AutoFilter Field:=5, Criteria1:=sh2.Cells(i, 1).Value
Selection.Copy
With ThisWorkbook
Set ws = .Sheets.Add(After:=.Sheets(.Sheets.count))
ws.Name = sh2.Cells(i, 2).Value
End With
Sheets(sh2.Cells(i, 2).Value).Select
'Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
Selection.PasteSpecial Paste:=xlPasteValuesAndNumberFormats, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
ActiveSheet.UsedRange.Columns.AutoFit
Next i
sh1.Activate
ActiveSheet.UsedRange.Select
Selection.AutoFilter
sh1.Range("E1").AutoFilter Field:=5, Criteria1:="Field Difference"
Selection.Copy
Sheets("Field Difference").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
ActiveSheet.UsedRange.Columns.AutoFit
MsgBox "Field Difference Copy completd"
' Step 2. Insert 11 lines and Insert 4 columns for analysis
Set sh3 = wb.Sheets("Field Difference")
Dim x As Long
Dim j As Long
Dim i1 As Long
Dim fieldRows As Long
j = 1
fieldRows = sh3.UsedRange.Rows.count
Dim rowsAfterInsertingLines As Long
rowsAfterInsertingLines = fieldRows / 2
Const count = 11
For i1 = 2 To fieldRows
If i1 Mod 2 = 1 Then
For x = 1 To count
sh3.Rows(i1 + j).Insert Shift:=xlDown
j = j + 1
Next
End If
Next i1
MsgBox "Inserted Lines Done"
' Inserting 4 columns before the first column
sh3.Range("A:D").EntireColumn.Insert Shift:=xlToRight
sh3.Range("A1").Value = "Data Source Name"
sh3.Range("B1").Value = "Final Status"
sh3.Range("C1").Value = "UserName"
sh3.Range("D1").Value = "Ownership"
MsgBox "Columns Inserted"
' Now a Loop to insert the values - (CMRS, DTCC-US, Difference, 2 Eye Check, 4 Eye Check)
Dim myModifiedArray() As Variant
myModifiedArray = Array("CMRS", "DTCC-US", "Difference", "Sapient Comments (History)", "Last Sapient Comment / 2 Eye Analysis", "4 Eye Analysis", "4 Eye Comments", "Last Comment made by (Sapient)", "Date of Last Comment (Sapient)", "NWM Comment (History)", "Last NWM Commnent", "Last Comment made by (NWM)", "Date of Last Comment (NWM)")
Dim rCount As Long
rCount = 2
Dim iCount As Long
Dim jCount As Long
For iCount = 1 To rowsAfterInsertingLines
For jCount = LBound(myModifiedArray) To UBound(myModifiedArray)
sh3.Cells(rCount, 1).Value = myModifiedArray(jCount)
rCount = rCount + 1
Next jCount
Next iCount
MsgBox "Row headers inserted"
End Sub
I have a sub which looks for values in the SolutionID column that match an array of values in one table, and then copies that over to the other.
However, I'm hitting an error with the .PasteSpecial method -
Object doesn't support this property or method
Does anybody know what I am doing wrong? Thanks.
Private Sub CopySolutions(ByRef SourceTable As ListObject, ByRef DestinationTable As ListObject, ByRef values() As String)
On Error Resume Next
Dim i, j As Integer ' Dummy for looping
'** Loop through all of the ID's to copy... *'
For i = LBound(values) To UBound(values)
With SourceTable.DataBodyRange
For j = 1 To .Rows.Count
If .Cells(j, 1).Value = values(i) Then
.Rows(j).Copy ' Copy the row in the SourceTable
Dim LastRow As Integer
LastRow = DestinationTable.Rows.Count ' Work out the number of rows in the DestinationTable
'** Check to see if the last row in the destination table is already empty '*
If DestinationTable.DataBodyRange.Cells(LastRow, 1).Value <> "" Or LastRow = 0 Then
DestinationTable.ListRows.Add AlwaysInsert:=True ' Insert a new row in to the DestinationTable
LastRow = LastRow + 1 ' Increment LastRow to take in to account the newly added row
End If
DestinationTable.DataBodyRange.Cells(LastRow, 1).Select ' Select the last row, column 1 in the Destination Table
Selection.PasteSpecial Paste:=xlPasteValues, _
Operation:=xlNone, _
SkipBlanks:=False, _
Transpose:=False ' Paste the copied row
Exit For ' Exit the For, there is no need to keep checking for matches
End If
Next
End With
Next
If Err.Number <> 0 Then
Call ErrorOutput("An error occured while copying your selected solutions.")
End If
On Error GoTo 0
WS.Range("Solution").Select ' Reselect the Solution cell range
End Sub
Best to avoid copy/paste alltogether:
Dim rngSrc as Range
'...
Set rngSrc = .Rows(j)
'...
DestinationTable.DataBodyRange.Cells(LastRow, 1). _
Resize(1, rngSrc.Columns.Count).Value = rngSrc.Value
Try this:
SourceTable.DataBodyRange.Rows(j).Copy DestinationTable.DataBodyRange.Range("A" & CStr(lastRow))
after you find last row of course. That way you don't have to use .Select
I have the below code that is suppose to copy data from an excel file I receive in a email and paste it to another file on the row that has the same date. When I try and run the macro it says there is an error. Can anyone look at my code and direct me as to where my error is. I am fairly new to coding and creating macros.
Sub CopyDataToPlan()
Dim LDate As String
Dim LColumn As Integer
Dim LFound As Boolean
Dim WS As Worksheet
On Error GoTo Err_Execute
Set WS = Workbooks("McKinney Daily Census Template OCT 10.xls").Sheets("McKinney")
'Retrieve date value to search for
WS = Workbooks("McKinney Daily Census Template OCT 10.xls").Cell("B15").Value
Sheets("Input").Select
'Start at column B
LColumn = 2
LFound = False
While LFound = False
'Encountered blank cell in row 2, terminate search
If Len(Cells(2, LColumn)) = 0 Then
MsgBox "No matching date was found."
Exit Sub
'Found match in row 2
ElseIf Cells(2, LColumn) = LDate Then
'Select values to copy from "McKinney" sheet
Sheets("McKinney Daily Census Template OCT 10.xls").Select
Range("C15:I15").Select
Selection.Copy
'Paste onto "Key Indicator" sheet
Sheets("Input").Select
Cells(3, LColumn).Select
Selection.PasteSpecial Paste:=xlValues, Operation:=xlNone, SkipBlanks:= _
False, Transpose:=False
LFound = True
MsgBox "The data has been successfully copied."
'Continue searching
Else
LColumn = LColumn + 1
End If
Wend
On Error GoTo 0
Exit Sub
Err_Execute:
MsgBox "An error occurred."
End Sub
What line generates the error? It seems that your variable LDate never recieves a date. May be instead of
WS = Workbooks("McKinney Daily Census Template OCT 10.xls").Cell("B15").Value
you meant to write
LDate = Workbooks("McKinney Daily Census Template OCT 10.xls").Cell("B15").Value
All this looks like pretty lenghty and dangerous code: why not a) get both the date from your input sheet and the data you want to copy (looks like you could put these in an array with a for loop) and then b) search for the cell that contains the date you want (1 statement) to retrieve the row of the cell that matches the date you want, and then c) loop the data from the array to the sheet.
Be more explicit with references . The code runs faster and is easier to debug:
Sub CopyDataToPlan()
Dim LDate As String
Dim LColumn As Integer
Dim LFound As Boolean
Dim WkbCensus As workbook
Dim WksCensus As worksheet
Dim WkbThis As workbook
Dim WksInput As worksheet
On Error GoTo Err_Execute
Set WkbThis = thisworkbook
Set wksInput = WkbMe.Sheets("Input")
Set WkbCensus = Workbooks("McKinney Daily Census Template OCT 10.xls")
Set WksCensus = Wkb.Sheets("McKinney")
LDate = WksCensus.Cell("B15").Value
LColumn = 2
LFound = False
While LFound = False
If Len(wksInput.cells(2, LColumn)) = 0 Then
MsgBox "No matching date was found."
Exit Sub
ElseIf wksInput.cells(2, LColumn) = LDate Then
WksCensus.Range("C15:I15").copy
wksInput.cells(3, LColumn).pastespecial Paste:=xlValues, Operation:=xlNone, _
SkipBlanks:=False, Transpose:=False
LFound = True
MsgBox "The data has been successfully copied."
Else
LColumn = LColumn + 1
End If
Wend
On Error GoTo 0
Exit Sub
Err_Execute:
MsgBox "An error occurred."
End Sub