I have written some VBA in excel to iterate a relatively large set of data in order to perform some basic formatting and tidying up. The code previously worked and still works when I use a break point and step through it. However, when i don't step through it and just let the code run by itself, the spreadsheet becomes unresponsive. Once I've pressed escape a few times I get the runtime 1004 error (see title) and the relevant line is hightlighted.
I'd like to reiterate that when i set a break point on the offending line and step through it, it works fine and the row is deleted as appropriate. Also when I test the syntax in a much smaller data set it works perfectly so this is not syntax related.
Any help will be greatly appreciated because I'm stumped. Here is the code:
Private Sub CommandButton21_Click()
Dim index As Integer, lapsedSchemes As New Collection, lapseDates As New
Collection
Dim iRow As Long
Dim iCol As Integer
Sheet1.Columns(5).NumberFormat = "dd-mmm-yy"
Sheet1.Columns(14).NumberFormat = "dd-mmm-yy"
iRow = 2
Do While Sheet3.Cells(iRow, 1).Value <> ""
lapsedSchemes.Add Sheet3.Cells(iRow, 1).Value
lapseDates.Add Sheet3.Cells(iRow, 2).Value
iRow = iRow + 1
Loop
iRow = 2
Do While Cells(iRow, 7).Value <> ""
index = 1
If Cells(iRow, 9).Value = "" Then
If Cells(iRow, 7).Value = Cells(iRow, 8).Value Then
Cells(iRow, 9).Value = "Policy Holder"
Else
Cells(iRow, 9).Value = "Dependant"
End If
End If
For Each scheme In lapsedSchemes
If Cells(iRow, 4).Value = scheme And Cells(iRow, 5) = lapseDates(index) Then
Cells(iRow, 4).EntireRow.Delete
iRow = iRow - 1
Exit For
End If
index = index + 1
Next scheme
iRow = iRow + 1
Loop
appendLegacyData (iRow)
Range("A1:AZ10000").Sort Key1:=Range("A1"), Order1:=xlAscending, Key2:=Range("D1"), Order2:=xlAscending, Key3:=Range("E1"), Order3:=xlAscending, Header:=xlYes
End Sub
The offending line is:
Cells(iRow, 4).EntireRow.Delete
The sheet becomes unresponsive and only when I press escape a few times does the runtime error show.
Unresponsive doesn't mean that Excel crashed. Deleting rows one by one is just painfully slow.
You can use
application.statusbar=cstr(iRow)
DoEvents
to see your progress and keep Excel responsive.
If it will work to slow, I recommend you to set some value in rows to delete, sort by that value and then delete them all together.
Related
I am trying to create a conditional loop macro in Excel. Column B contains a last name, Column C contains a first name, and Column D contains a first and last name. I am trying to get the macro to detect when Column D = Column C + Column B.
If D = C + B, then clear contents of D.
So, the following works for a single row:
Sub ClearContentsD ()
If Range("D1").Value = Range("C1").Value + Space(1) + Range("B1") Then Range("D1").ClearContents
End Sub
It does not work without the added Space(1), and I cannot get it to loop through the whole worksheet:
Sub ClearContentsLoop()
Application.ScreenUpdating = False
Dim i As Long
For i = 1 To Rows.Count
Next i
Do While Cells(i, 4).Value = Cells(i, 3).Value + Space(1) + Cells(i, 2).Value
Cells(i, 4).ClearContents
Loop
Application.ScreenUpdating = True
End Sub
VBA doesn't like my Do While. Any help would be greatly appreciated.
CJ
Some issues:
You must concatenate strings with &. The plus (+) is for addition;
Your For loop is not doing anything: its body is empty;
Your Do While Loop will at most run once, because i is not incremented;
It is a mystery why you would want two loops (For and Do While);
A sheet has many rows of which you only use a fraction, so don't loop through all of them (For) and use UsedRange.
Possible correction:
Sub ClearContentsLoop()
Dim i As Long
Application.ScreenUpdating = False
For i = 1 To ActiveSheet.UsedRange.Rows.Count
If Cells(i, 4).Value = Cells(i, 3).Value & " " & Cells(i, 2).Value Then
Cells(i, 4).ClearContents
End If
Next i
Application.ScreenUpdating = True
End Sub
There is a way to ignore the space in the values you are evaluating. Try this:
Application.ScreenUpdating = False
Dim i As Long
For i = 1 To Rows.Count
If InStr(1, Cells(i, 4).Value, Cells(i, 2).Value, vbTextCompare) > 0 And InStr(1, Cells(i, 4).Value, Cells(i, 3).Value, vbTextCompare) > 0 Then Cells(i, 4).ClearContents
Next i
Application.ScreenUpdating = True
Explanation:
By using the InStr function, you are testing for the presence of one text string inside of another, and if at least one match is found, then the function returns a non-zero value (the position where the match was found). In the above example, you are testing for the presence of the first name and last name at the same time, and if both are found, then the code clears out the contents of the cell.
And, as was pointed out in the comments section, you need to do this inside the loop so that all cells down the length of the worksheet are evaluated and updated as specified.
Be sure to test this on a COPY of your original data so that you don't lose the original values in case you want to roll back your changes! ;)
So I am currently trying to have a user input some information and put that information in a specific range based on what values in the dropdown list are selected. For example, I selected Monday, so I want the information to go in the Range A1:A12, but if they select Tuesday then go to range G1:G12.
Also, if the range is already full with data, I'd like for it to tell the user that it is full. Do not have any example code, but here is a psuedo-code example
Private Sub cbSubmit_Click()
range("A2").Select
ActiveCell.End(xlDown).Select
lastrow = ActiveCell.Row
MsgBox lastrow
If ComboBox1.Value = "Monday" Then
Cells(lastrow + 1, 1).Value = tb1.Text
Cells(lastrow + 1, 2).Value = tb2.Text
End If
If ComboBox1.Value = "Tuesday" Then
range("G2").Select
ActiveCell.End(xlDown).Select
lastrow2 = ActiveCell.Row
Cells(lastrow2 + 1, 1).Value = tb1.Text
Cells(lastrow2 + 1, 2).Value = tb2.Text
End If
End Sub
Also, in the above code, is there a better way to find the last cell in the range that is blank? This one only works if there is already data in the range and that's not always the case.
And also check some sort of CountA or something to see if the range is already full of data. Thanks in advance!
I will answer just so I can demonstrate code better.
As I said in the comments, if you want to check each value in a range, you can do so like this:
Dim c
For Each c in Range("A1:A10") 'Whatever your range to check is
If c <> vbNullString Then
'Found Data - not empty
Exit For
End If
Next
If you're just checking 2 cells as it looks like you are, you should probably just use:
If Cells(lastrow2 + 1, 1) <> vbNullString and Cells(lastrow2 + 1, 2) <> vbNullString
If you just want to add the data to the bottom of the list, your code is already getting the last row and adding to it ... so each time you call this:
ActiveCell.End(xlDown).Select
lastrow2 = ActiveCell.Row
It is getting the last row and the rest of your code adds it to the end.
One more thing. You should really replace this:
range("G2").Select
ActiveCell.End(xlDown).Select
lastrow2 = ActiveCell.Row
With this:
lastrow2 = range("G2").End(xlDown).Row
You should avoid using select as often as possible.
In my experience, it is really only necessary when displaying a different sheet.
I'm writing up a sub which grabs specific cells from the active workbook (order form), opens a specified workbook (report) and drops in the values in a particular order. Oddly, this works just fine when stepped through and I can see the report workbook open and the values fill, but when run it opens the workbook but doesn't seem to change it.
Code as follows (a bit rough and ready, I'm still learning...)
Sub TransferTheData()
Dim mySheet As Worksheet, myOtherSheet As Worksheet
Dim myOtherBook As Workbook
Dim i As Integer, j As Integer
Dim vToday As String
Set myOtherBook = Workbooks.Open("c:\\Test\Test Report.xlsx")
Set mySheet = ThisWorkbook.Sheets("Order Form")
Set myOtherSheet = myOtherBook.Sheets("Sheet1")
vToday = Format(Date, "dd/mmmm/yyyy")
j = myOtherSheet.Range("A" & Rows.Count).End(xlUp).Row + 1
For i = 18 To 85
If mySheet.Cells(i, 1).Value <> "" Then
'Loop through 68 rows and copy values
myOtherSheet.Cells(j, 3).Value = mySheet.Cells(i, 1).Value
myOtherSheet.Cells(j, 4).Value = mySheet.Cells(i, 2).Value
myOtherSheet.Cells(j, 5).Value = mySheet.Cells(i, 3).Value
'constant values copied to each row in report sheet
myOtherSheet.Cells(j, 1).Value = mySheet.Cells(5, 2).Value
myOtherSheet.Cells(j, 2).Value = mySheet.Cells(9, 5).Value
myOtherSheet.Cells(j, 8).Value = vToday
myOtherSheet.Cells(j, 6).Value = mySheet.Cells(9, 2).Value
myOtherSheet.Cells(j, 7).Value = mySheet.Cells(6, 2).Value
j = j + 1
End If
Next i
End Sub
Can anyone see where I've gone wrong? Been looking at it for hours scratching my head...
Quite typically, after looking at it for hours and then posting a question, I found the answer right here on SO!
This thread discusses and answers the issue. No shift keys in keyboard shortcuts using the Open method of the workbook object (I think):
The shift key makes a vb script stop at any Open statement.
Switched .open for .add and we're rolling with full functionality as expected! :)
I'm very new to VBA, and I'm trying to move particular items within a column to another sheet for a report.
This is my Macro:
Sub DoIHaveaPRDesignation()
Dim rng As Range
Dim i, Lastrow
Dim splitValues() As String
Lastrow = Sheets("Sheet1").Range("A" & Rows.Count).End(xlUp).Row
Sheets("Sheet2").Range("A1:I500").ClearContents
Sheets("Sheet2").Cells(1, 1).Value = "Pair"
Sheets("Sheet2").Cells(1, 2).Value = "Commit"
Sheets("Sheet2").Cells(1, 3).Value = "CKID"
Sheets("Sheet2").Cells(1, 4).Value = "Status"
Sheets("Sheet2").Cells(1, 5).Value = "Terminal"
Sheets("Sheet2").Cells(1, 6).Value = "Address"
Set rng = ActiveCell
Dim moveValue As String
Do While rng.Value <> Empty
If InStr(rng.Value, " pr") = 0 Then
MsgBox "Haven't found Pair "
Else
MsgBox rng.Value
End If
Set rng = rng.Offset(1)
rng.Select
Loop
MsgBox "Done!"
End Sub
This is one instance of the data (Column A, Rows 1 - 6):
pr 1 stat RCT commit stat P
sys: type 73RMD no 1 slot: 1 lt: field stat DZ7K co stat NREQ
ckid NONE lp stat RCT 11-30-13 bp/clr 601 tea 1975 W SOUTHPORT RD
type FIXED tec IPLPINPL fld side capr 1975W:279
dist tea 7250 WINSLET BLVD type FIXED addr: 7250 WINSLET BLVD
UNIT 2D serv tea 7250 WINSLET BLVD type FIXED
The code finds the occurance of "pr", but I cannot seem to fidgure out how to pick it up and move it. I need to repeat this for the 6 columns I formatted on sheet 2, but if I get help with the first I can figure out the rest.
Thanks!
This answer discusses features of your existing code that are not recommended and introduces techniques that I believe are relevant to your requirement.
Issue 1
Dim i, Lastrow
The above declares i and Lastrow as variants which can hold anything. For example, the following code is valid:
i = "A"
i = 5
Variants can be very useful but they are slower to access than properly typed variables. I recommend:
Dim i As Long, Lastrow As Long
Issue 2
Sheets("Sheet2").Range("A1:I500").ClearContents
I assume Range("A1:I500") is intended to be larger than the area that was used on a previous run of the macro.
I would write Sheets("Sheet2").Cells.ClearContents and let Excel worry about the range used last time.
Note that ClearContents, as the name implies, only clears the contents. Clear will also clear any formatting. Sheets("Sheet2").Cells.EntireRow.Delete will delete contents and formatting and restore the column widths to their default. However, ClearContents may be adequate for your needs.
Issue 3
Sheets("Sheet2").Range("A1:I500").ClearContents
Sheets("Sheet2").Cells(1, 1).Value = "Pair"
Sheets("Sheet2").Cells(1, 2).Value = "Commit"
Sheets("Sheet2").Cells(1, 3).Value = "CKID"
Sheets("Sheet2").Cells(1, 4).Value = "Status"
Sheets("Sheet2").Cells(1, 5).Value = "Terminal"
Sheets("Sheet2").Cells(1, 6).Value = "Address"
Use of the With statement generally makes your code clearer and faster:
With Sheets("Sheet2")
.Range("A1:I500").ClearContents
.Cells(1, 1).Value = "Pair"
.Cells(1, 2).Value = "Commit"
With .Cells(1, 3)
.Value = "CKID"
.Interior.Color = RGB(0, 240, 240)
End With
.Cells(1, 4).Value = "Status"
.Cells(1, 5).Value = "Terminal"
.Cells(1, 6).Value = "Address"
End With
I have coloured cell C1 to show that With statements can be nested.
Issue 4
Set rng = ActiveCell
As I understand it, the source data is in worksheet Sheet1 and starts at cell A1. The above means your code will start at whatever cell in whatever worksheet the user has positioned the cursor. If there is a fixed starting point then set that in your code. If you do want the user to be able to control the starting point consider:
If ActiveCell.Worksheet.Name <> "Sheet1" Then
Call MsgBox("Please position the cursor to the desired starting " & _
"point in worksheet ""Sheet1""", vbOKOnly)
Exit Sub
End If
Issue 5
Set rng = ActiveCell
:
Set rng = rng.Offset(1)
rng.Select
Accessing a selected cell is much slower than accessing the cell using VBA addressing. I have also seen programmers get hopeless confused about the current location of the cursor when using Offset. You have used VBA addressing to set the header row and I have used it in my sample code below.
Issue 6
Lastrow = Sheets("Sheet1").Range("A" & Rows.Count).End(xlUp).Row
Do While rng.Value <> Empty
You set Lastrow to the number of the last row with a value but your loop moves down the column until it hits an empty cell. If there are no empty rows within the body of the data, this will give the same result. However I suggest you decide which approach is appropriate.
I would avoid the use of Empty. See What is the difference between =Empty and IsEmpty() in VBA (Excel)?.
Sample code
The following code includes the parts relevant to your question. I move the contents of cells containing " pr" to column 1 of worksheet "Sheet2" which is what you seem to be asking. However, if you wanted to split cells containing " pr" and copy selected parts to Sheet2, I would have handled your requirement in a different way. I can add a further section to this answer if you clarify what you seek.
Option Explicit
Sub MovePRRows()
Dim Rng As Range
Dim RowSheet1Crnt As Long
Dim RowSheet1Last As Long
Dim RowSheet2Crnt As Long
Dim WSht2 As Worksheet
Set WSht2 = Worksheets("Sheet2")
WSht2.Cells.EntireRow.Delete
RowSheet2Crnt = 2
With Worksheets("Sheet1")
RowSheet1Last = .Cells(Rows.Count, "A").End(xlUp).Row
For RowSheet1Crnt = 1 To RowSheet1Last
Set Rng = .Cells(RowSheet1Crnt, 1)
If Rng.Value <> "" Then
If InStr(1, Rng.Value, " pr") <> 0 Then
Rng.Copy Destination:=WSht2.Cells(RowSheet2Crnt, 1)
RowSheet2Crnt = RowSheet2Crnt + 1
End If
End If
Next
End With
End Sub
Disclaimer: I've never used Visual Basic and I've never made a macro.
I am trying to create a macro in Microsoft Excel 2010 that will delete all rows where neither column G nor column I contain the string "Ohio", "Indiana", or "Kentucky". To clarify, the row should be deleted if the cell does not contain either of those three state names. I want the macro to start at row 6, as rows 1-5 contain vital information. The whole sheet contains over 14000 rows and only ~1.5% of those are actually helpful.
Also, I am looking to be able to reuse this macro, but for other terms (besides Ohio, Indiana, and Kentucky) in other columns (besides G and I).
It may also help me if you can, besides correcting this, explain what exactly I am saying in these lines. Perhaps in Java terms, or Python is okay too. Not necessary, but may help.
Sub DeleteIfNotKYINOH()
Dim i, LastRow
LastRow = Range("G" & Rows.Count).End(xlUp).Row
For i = LastRow To 6 Step -1
I get a type mismatch error on the next line.
If Cells(i, "G").Value = "Ohio" Or "Indiana" Or "Kentucky" Then
Cells(i, "G").Value = True
End If
If Cells(i, "I").Value = "Ohio" Or "Indiana" Or "Kentucky" Then
Cells(i, "I").Value = True
End If
If Cells(i, "G").Value Or Cells(i, "I").Value = False Then
Cells(i, "G").EntireRow.Delete
End If
Next
' DeleteIfNotKYINOH Macro
' Delete all rows that do not contain Ohio, Indiana, or Kentucky, as a state.
'
'
End Sub
There are a few things to consider, it looks like you are on the right track, though, you even got the backwards iteration over the collection (this stumps a lot of people!).
Make sure to declare your variables properly (i and LastRow should probably be Long integer, not unspecified Variant type).
If statements can include Or joins, but have to be like this:
If Cells(i, "G").Value = "Ohio" Or Cells(i, "G").Value = "Indiana" Or Cells(i, "G").Value = "Kentucky"
Since you want to be able to re-use the macro for other strings, of course you could go in and edit each instance of "Ohio" or "Indiana", etc., but that can be tedious and error-prone.
You could do something like this instead to re-use it for a list of any number of states, just change the assignment to the states variable.
Const states as String = "Ohio,Indiana,Kentucky"
Sub TestDeleteIfNot()
Dim i as Long, LastRow as Long
Dim cl as Range
LastRow = Range("G" & Rows.Count).End(xlUp).Row
For i = LastRow To 6 Step -1
With Cells(i, "G")
If Not(InList(.Value, states)) And Not(InList(.Offset(0,2).Value, states))
.EntireRow.Delete
End If
End With
Next
End Sub
This routine calls on a function InList which accepts as its arguments two strings. The first string should be the value being compared, and the second is a comma-delimited "list" of allowable values.
Function InList(strVal as String, list as String) As Boolean
Dim a as Variant
For each a in Split(list, ",")
If strVal = a Then
InList = True
Exit For
End If
Next
End Function
The function converts the list to an array and iterates that against the compare value. It should return False if the value is not found. So then the logic in the calling sub runs this on cells in COlumn G and also Column I, only deleting the row if BOTH tests return False.