I have a userform that has a drop down box in which a person can select a record to have deleted off a list.
The code below is deleting the ENTIRE ROW. I do not want that. I just want the cells between A:E cleared on my spreadsheet.
I am not sure how else to describe this so I apologize in advance. Here is the code:
Private Sub CheckBox1_Click()
End Sub
Private Sub CommandButton1_Click()
Dim lRw As Long
ActiveWorkbook.Sheets("RAWDATA").Visible = xlSheetVisible
'get the row number. add 2 because ListIndex starts at one
lRw = Me.ComboBox1.ListIndex + 2
ActiveWorkbook.Sheets("RAWDATA").Select
Cells(lRw, 1).EntireRow.ClearContents
ActiveWorkbook.Sheets("RAWDATA").Visible = xlSheetHidden
End Sub
Private Sub CommandButton2_Click()
ComboBox1.Value = ""
ComboBox1.Clear
ComboBox1.Clear
Unload Me
End Sub
Private Sub UserForm_Initialize()
'assumes data starts in A1 and has a header row
Me.ComboBox1.List = ActiveWorkbook.Sheets("RAWDATA").Cells(1, 2).CurrentRegion.Offset(1, 2).Value
End Sub
side note: You don't need to select the cells to manipulate the contents in vba.
Check out this link to explain that concept in more detail:
how-to-avoid-using-select-in-excel-vba-macros
This is the problem code. You are clearing the entire row, using ".EntireRow.ClearContents"
ActiveWorkbook.Sheets("RAWDATA").Select
Cells(lRw, 1).EntireRow.ClearContents
ActiveWorkbook.Sheets("RAWDATA").Visible = xlSheetHidden
Here are three solutions. Both should give you some insight into how the .Cells(row,col) idea works while using a loop. You are using a variable to control the row number, and the same concept can be applied to the column. Even though it's just 5 columns. It might be 50 for another project. So you can loop through them using a "For Loop" This is my preferred method.
If you want to get loopy, try something like this. Use a Variable for the Column
For lCol = 1 To 5
Sheets("RAWDATA").Cells(lRw, lCol).ClearContents
Next lCol
You can do one cell at a time Directly coding the column number:
Sheets("RAWDATA").Cells(lRw, 1).ClearContents
Sheets("RAWDATA").Cells(lRw, 2).ClearContents
Sheets("RAWDATA").Cells(lRw, 3).ClearContents
Sheets("RAWDATA").Cells(lRw, 4).ClearContents
Sheets("RAWDATA").Cells(lRw, 5).ClearContents
You can do one cell at a time Directly coding the column LETTER:
Sheets("RAWDATA").Cells(lRw, "A").ClearContents
Sheets("RAWDATA").Cells(lRw, "B").ClearContents
Sheets("RAWDATA").Cells(lRw, "C").ClearContents
Sheets("RAWDATA").Cells(lRw, "D").ClearContents
Sheets("RAWDATA").Cells(lRw, "E").ClearContents
edit: added some explanation and link
The cells(lRw, 1).EntireRow.ClearContents is your issue. The EntireRow function selects the row which is pointed to by cells(lRw, 1). The .ClearContents function clears what's selected. You should replace it with something like:
Range("A" & <the row number> & ":J" & <the row number>).clearcontents
Your variable lRw is supposed to hold the value of the row in which the selected project is located, correct? If so, then:
Range("A" & lRw & ":J" & lRw ).clearcontents
should work. You can change the column letters to whatever you'd like to clear.
I think PJ Rosenburg's solutions are bit impractical, but I agree with the fact that you should shy away from using the .select function. You can do everything you need to do without using it. You'll write much better code once you understand this concept. In fact, here's a rewrite of your commandButton1_click that should do the exact same thing, but with less code and is easier to read.
Private Sub CommandButton1_Click()
Dim lRw As Long
lRw = Me.ComboBox1.ListIndex + 2
with ActiveWorkbook.Sheets("RAWDATA")
.Visible = xlSheetVisible
.Range("A" & lRw & ":J" & lRw ).clearcontents
.Visible = xlSheetHidden
end with
end sub
Notice a couple of things:
No .select
Moving the assignment statement
The addition of the With/End With statements
Anyway, I hope this helps and better explains what I was trying to say earlier.
Related
I am trying to add comments to specific cells in a range if they meet criteria. So I have a list in Sheet1 where the information is housed. I also have the cell value on sheet16 where I want the comment in column U, so it will say F6 in row U. I keep getting
Application-Defined or object-defined error
Any thoughts?
Thanks in Advance.
Sub Comments()
Dim rcell As Range
Sheet16.Range("C6:AR17").ClearComments
For Each rcell In Sheet1.Range("A2:A" & Sheet1.Range("A" & Sheet1.Rows.CountLarge).End(xlUp).Row)
If rcell.Offset(0, 1).Value(10) = Sheet7.Range("G1").Value(10) Then
commentvalue = rcell.Offset(0, 4).Value
Sheet16.Range("U" & rcell.Row).AddComment (commentvalue)
End If
Next rcell
End Sub
The AddComment method fails if there's already a comment on a cell. Do it like this:
Sub Comments()
Dim rcell As Range
Dim commentvalue As String
Sheet16.Range("C6:AR17").ClearComments
For Each rcell In Sheet1.Range("A2:A" & Sheet1.Range("A" & Sheet1.Rows.CountLarge).End(xlUp).row)
If rcell.Offset(0, 1).Value = Sheet7.Range("G1").Value Then
commentvalue = CStr(rcell.Offset(0, 4).Value)
With Sheet16.Range("U" & rcell.row)
.ClearComments '<=== :-)
.AddComment commentvalue
End With
End If
Next rcell
End Sub
Edit
As per #Jeeped's comment, you could want to "cumulate" comments. My assumption was that you ran the code once, then ran it again and hit the error because the first run had created the comments. Depending on what you try to achieve, you may want to systematically clear the comments in column U from rows 2 to your last row, outside of the loop, and remove the .ClearComments in the loop, in order to start clean each time. That's the simplest case. I'll let you work out the details if it's anything more complicated.
This is a continuation for the following question: What is the cause for Conditional Formatting to get jumbled up?
In an attempt to prevent my conditional formatting from going haywire, I decided to convert it into code in VBA. I decided to start small and start with converting one conditional formatting into VBA.
Explanation:
In column O there are a series of numbers, obtained from a different sheet. User inputs number in column F. For example if number in F9 is less than O9, the font colour will become red. If not number remains normal. The formula should start at row 9 and can continue down onwards and should be automatic.
Meaning the moment a number is keyed in column F the font colour should change instantly.
The following is the code I created so far:
Sub change_color()
With Me.Range("f9", Range("f" & Rows.Count).End(xlUp)) 'so the formula will carry onwards from f9 onwards
If f9 < o9 Then
Range(f).Font.Color = vbRed
End If
End With
End Sub
But alas it didn't work. I also tried linking it to a button and nothing happens. And I also remember to remove my old conditional formatting as well. Is there something I'm missing?
You are after something like the code below.
This code is to be ran once, it will lopp through the entire column "F" in your worksheet, and change the font of all instances.
Regular Module Code
Option Explicit
Sub change_color()
Dim LastRow As Long, i As Long
With Worksheets("Sheet1") ' modify to your sheet's name
LastRow = .Cells(.Rows.Count, "F").End(xlUp).Row
For i = 1 To LastRow
If .Range("F" & i).Value < .Range("O" & i).Value Then
.Range("F" & i).Font.Color = vbRed
Else
.Range("F" & i).Font.Color = vbBlack
End If
Next i
End With
End Sub
To "catch" the modification in real-time, when someone changes a value in column "F", and then change the font according to the criteria you specified, you need add the following code to the Worksheet module, where you have your data, and add the piece of code below to Worksheet_Change event.
Code in Sheet1 module (modify to your sheet's)
Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Column = 6 Then ' if someone changes a value in column "F"
Application.EnableEvents = False
If Target.Value < Range("O" & Target.Row).Value Then
Target.Font.Color = vbRed
Else
Target.Font.Color = vbBlack
End If
End If
Application.EnableEvents = True
End Sub
Does this work for you?
Option explicit
Sub ChangeColor()
With thisworkbook.worksheets(YOURSHEETNAME) 'Replace with sheet name as per your workbook.'
Dim LastRow as long
Lastrow = .cells(.rows.count,"F").end(xlup).row
Dim RowIndex as long
For rowindex = 9 to LastRow
If .cells(rowindex,"F").value2 < .cells(rowindex,"O").value2 then
.cells(rowindex,"F").font.color = vbred
End if
Next rowindex
End With
End Sub
I have a sheet FC, with this sheet, I have column R, S and T filled.
I would prefer to have a code, which checks if R contains "invalid" and if S and t are filled, then it should filter complete row.
I know we can use isblank function to check whether the cell is blank or not,
but I am struck how I can use a filter function with these condition .Any help will be helpful for me. I am struck how I can proceed with a vba code. Apologize me for not having a code.
You will have to somehow specify last row:
Dim lastRow, i As Long
For i = 1 To lastRow 'specify lastRow variable
If InStr(1, LCase(Range("R" & i).Value), "invalid") > 0 And Range("S" & i).Value = "" And Range("T" & i).Value = "" Then
'do work
End If
Next i
In our If condition we check three things that you asked.
Try this
Sub Demo()
Dim lastRow As Long
Dim cel As Range
With Worksheets("Sheet3") 'change Sheet3 to your data sheet
lastRow = .Cells(.Rows.Count, "R").End(xlUp).Row 'get last row in Column R
For Each cel In .Range("R5:R" & lastRow) 'loop through each cell in range R5 to lase cell in Column R
If cel.Value = "invalid" And Not IsEmpty(cel.Offset(0, 1)) And Not IsEmpty(cel.Offset(0, 2)) Then
cel.EntireRow.Hidden = True 'hide row if condition is satisfied
End If
Next cel
End With
End Sub
EDIT :
To unhide rows.
Sub UnhideRows()
Worksheets("Sheet3").Rows.Hidden = False
End Sub
Assuming Row1 is the header row and your data starts from Row2, in a helper column, place the formula given below.
This formula will return either True or False, then you may filter the helper column with either True or False as per your requirement.
=AND(R2="Invalid",S2<>"",T2<>"")
In case your header row is different, tweak the formula accordingly.
sub myfiltering()
'maybe first row always 4
firstrow=4
'last, maybe R column alaways have any entered info, so let us see what is the last
lastrow=cells(65000,18).end(xlup).row
'go ahead
for myrow=firstrow to lastrow
if cells(myrow,18)="Invalid" and cells(myrow,19)="" and cells(myrow,20)="" then
Rows(myrow).EntireRow.Hidden = True
else
Rows(myrow).EntireRow.Hidden = false
end if
next myrow
msgbox "Filter completed"
end sub
hope this will help you :)
Why you need the vba code for this problem?
Its more simple if you add a new column with if & and formula, and autofiltering within the added col.
The formula may be similar like this in the U2 cell.
=if(and(R2="invalid";S2="";T2="");"x";"")
Also set autofilter to x. :)
Now I spent a few days searching up and down and need to find a solution.
I saw two threads but both are not what I am looking for exactly and I admit, being not too good in VBA, I cant make heads or tales.
What I have:
I have 4300 lines of Bank statements. There are multiple columns but 1 is of importance - Description. This description might contain a lot of things, but usually there is 1 key word that is crucial. Roughly 96% can be automated and 3-4% just written manually every now and then.
What I want:
A VBA Macro that will read the column description, will match a keyword there from a list of many such in Sheet2, column "keywords" and then write in Column Category (sheet1) the assigned Categorizaion taken from Column Category on Sheet2.
What I have done so far:
the only thing I found to be working for me, and be able to actually reproduce is using a formula:
=IF(ISNUMBER(SEARCH("KEYWORD",[Description])),"OUTPUT","")
The above formula was repeated multiple times but this slows and lags everything. Besides being unmanagable.
Its working but I need something better. So -> enter Macros. and here I am lost.
I found that the answer of #JohnBustos is very good here:
How to group excel items based on custom rules?
but not working for me really.
I found the answer of Tomk Dallimore to be what I need or want:
Categorizing bank transactions in Excel
but I cant make heads or tales how to get there??? He is very detailed but I am getting lost on the complexity which mind you is great.
Can you please help me?
I am attaching a very simple example of what I am talking.
http://1drv.ms/1Putpy5
Note#1
I founnd a new formula that I incorporated.
'=IFERROR(LOOKUP(10^10,SEARCH(" "&KeywordTable[In-keyword]&" "," "&H29& " "),KeywordTable[Out-keyword ]),"")
But this is also troubling the CPU as it calculates each time a cell is moved. I imagine it will throw exception if I add 560 new rows or better yet move the table with 1 poisition. Temporary solution but need something more sophisticated.
*****possibly a terrible idea****
To speed up the macro, such macro as the one you provided in your answer, is it possible to make it work like the automatic date filler macro:
Private Sub Worksheet_Change(ByVal Target As Excel.Range)
With Target
If .Count > 1 Then Exit Sub
If Not Intersect(Range("B2:B100"), .Cells) Is Nothing Then
Application.EnableEvents = False
If IsEmpty(.Value) Then
.Offset(0, 3).ClearContents
Else
With .Offset(0, 3)
.NumberFormat = "dd mmm yyyy hh:mm:ss"
.Value = Now
End With
End If
Application.EnableEvents = True
End If
End With
End Sub
Of course, I realize I am asking for something strange but if this can happen it will be rather fast and extremely helpful for optimzing the speed at which the macro is executed for large amounts of data. Now, I have 4500 rows to calculate. Within 2 months, this amount will double.
Based on your excel file this code works: 10'000 rows done in 3 secondes with this code.
Sub test()
Dim lastrow As Long, lastrow2 As Long
Dim i As Integer, j As Integer
Dim PatternFound As Boolean
Call speedup
lastrow = Sheets("Keywords").Range("A" & Rows.Count).End(xlUp).Row
lastrow2 = Sheets("SOURCE DATA").Range("E" & Rows.Count).End(xlUp).Row
For i = 4 To lastrow2
PatternFound = False
j = 1
Do While PatternFound = False And j < lastrow
j = j + 1
If UCase(Sheets("SOURCE DATA").Range("E" & i).Value) Like "*" & UCase(Sheets("Keywords").Range("A" & j).Value) & "*" Then
Sheets("SOURCE DATA").Range("F" & i).Value = Sheets("Keywords").Range("B" & j).Value
PatternFound = True
End If
Loop
Next i
Call normal
End Sub
Public Sub speedup()
Application.ScreenUpdating = False
Application.DisplayStatusBar = False
Application.Calculation = xlCalculationManual
Application.EnableEvents = False
End Sub
Public Sub normal()
Application.ScreenUpdating = True
Application.DisplayStatusBar = True
Application.Calculation = xlCalculationAutomatic
Application.EnableEvents = True
End Sub
I have a formula that shows which rows in a specific column meet a set of criteria. When the formula is executed and applied to all rows, I run a loop to check which rows returned a value as a text, and then copy-pastes this cells to another worksheet:
Sub loop1()
Dim r As Range, c As Range
With Worksheets("Sheet1")
Set r = Range(.Range("AF2"), .Range("AF2").End(xlDown))
For Each c In r
If WorksheetFunction.IsText(c) Then
Range(.Cells(c.Row, "AF"), .Cells(c.Row, "AF")).Copy
Else
GoTo nextc
End If
With Worksheets("Sheet2")
.Cells(Rows.Count, "A").End(xlUp).Offset(1, 0).PasteSpecial Paste:=xlPasteValues
End With
nextc:
Next c
End With
Application.CutCopyMode = False
End Sub
What I want to do now is to run the formula for 631 different names, copy-paste every name as a headline and then run loop1. I cant figure out though how to make the for loop work inside the formula.
Sub loop2()
Dim i As Integer
For i = 2 To 632
Sheets("Sheet1").Select
Range("AC2").Select
ActiveCell.FormulaR1C1 = _
"=IF(RC[-3]=""district1"",(IF(RC[2]=R2C33 ,(IF(RC[-18]>=1,0,(IF(RC[-16]>=1,0,IF(RC[-14]>=1,0,IF(RC[-12]>=1,0,IF(RC[-10]>=1,1,IF(RC[-8]>=1,1,IF(RC[-6]>=1,1,0))))))))),0)),0)"
Range("AC2").Select
Selection.AutoFill Destination:=Range("AC2:AC20753")
Range("AC2:AC20753").Select
Range("AG2").Select
Selection.Copy
Sheets("Sheet2").Select
ActiveSheet.Paste
Selection.Font.Bold = True
Sheets("Sheet1").Select
Application.Run "'Customers.xlsb'!loop1"
Next i
End Sub
The cells that need to be changed for every loop are, R2C33 to something like RiC33 (which doesn't work) and the "headline" Range("AG2").Select to something like Range("AGi").Select.
Anyone who could help?
The following code will do the trick:
Sub loop2()
Dim i As Integer
For i = 2 To 632
Sheets("Sheet1").Range("AC2:AC20753").FormulaR1C1 = _
"=IF(RC[-3]=""district1"",(IF(RC[2]=R" & i & "C33 ,(IF(RC[-18]>=1,0,(IF(RC[-16]>=1,0,IF(RC[-14]>=1,0,IF(RC[-12]>=1,0,IF(RC[-10]>=1,1,IF(RC[-8]>=1,1,IF(RC[-6]>=1,1,0))))))))),0)),0)"
Sheets("Sheet1").Range("AG" & i).Copy Destination:=Sheets("Sheet2").Range("A1")
Sheets("Sheet2").Range("A1").Font.Bold = True
Application.Run "'Customers.xlsb'!loop1"
Next i
End Sub
In order to let i be used within your String formula you have to stop the String " use & i & and continue the String ".
I have also changed your code to prevent the use of .Select, which is a no no in VBA.
This way it fills in your Formula copy's and changes the Font without selecting anything or changing sheets.
As Jeep noted you do however need to change Sheets(""Sheet2").Range("A1") as I don't know which cell you want to paste into.
Your first sub procedure might be better like this.
Sub loop1()
Dim r As Range, c As Range
With Worksheets("Sheet1")
Set r = Range(.Range("AF2"), .Range("AF2").End(xlDown))
For Each c In r
If WorksheetFunction.IsText(c) Then
Worksheets("Sheet2").Cells(Rows.Count, "A").End(xlUp).Offset(1, 0) = _
.Cells(c.Row, "AF").Value2
End If
Next c
End With
End Sub
Direct value transfer is preferred over a Copy, Paste Special, Values.
In the second sub procedure, you don't have to do anything but remove the 2 from R2C33; e.g. RC33. In xlR1C1 formula construction a lone R simply means the row that the formula is on and you are starting at row 2. You can also put all of the formulas in at once. Once they are in you can looop through the G2:G632 cells.
Sub loop2()
Dim i As Integer
With Sheets("Sheet1")
.Range("AC2:AC20753").FormulaR1C1 = _
"=IF(OR(AND(RC[-3]=""district1"", RC[2]=R2C33, RC[-18]>=1), SUM(RC[-16], RC[-14], RC[-12])>=1), 0, IF(SUM(RC[-10], RC[-8], RC[-6])>=1, 1, 0))"
For i = 2 To 632
.Range("AG" & i).Copy _
Destination:=Sheets("Sheet2").Somewhere
Sheets("Sheet2").Somewhere.Font.Bold = True
Application.Run "'Customers.xlsb'!loop1"
Next i
Next i
End Sub
I also tightened up your formula by grouping some of the conditions that would result in zero together with OR and AND functions.
The only thing remaining would be defining the Destination:=Sheets("Sheet2").Somewhere I left hanging.