Unable to Hide a column in Excel 97-2003 workbook - vba

I am trying to hide a column A1 in my sheet using vba. But am getting a error "unable to set hidden property of range class"
Here is my code:
ActiveWorkbook.Sheets("Project").Activate
ActiveSheet.Unprotect password
Dim cmt As comment
Dim iRow As Integer
For iRow = 1 To Application.WorksheetFunction.CountA(Columns(1))
Set cmt = Cells(iRow, 1).comment
If Not cmt Is Nothing Then
Cells(iRow + 1, 1) = Cells(iRow, 1).comment.Text
Cells(iRow, 1).comment.Delete
Else
MsgBox "No Comments"
End If
Next iRow
MsgBox ActiveSheet.ProtectionMode
ActiveSheet.Columns(1).Select
Selection.EntireColumn.Hidden = True
Am getting error in the line
Selection.EntireColumn.Hidden = True
I have included MsgBox to check whether the sheet is protected and is there any comment available in the cells of that column.
1st MsgBox returns as No Comments and 2nd returns as false.
So the sheet is not protected and comment is also not present.
Confused on why getting the error eventhough.
Please help me out
UPDATE:
I have changed my code like this:
ActiveWorkbook.Sheets("Project").Activate
Dim sh As Shape
Dim rangeToTest As Range
Dim lRow As Long
Dim c As Range
lRow = ActiveSheet.Range("A" & ActiveSheet.Rows.Count).End(xlUp).Row
Set rangeToTest = ActiveSheet.Range("A1:A" & lRow)
For Each c In rangeToTest
For Each sh In ActiveSheet.Shapes
sh.Delete
Next sh
Next c
ActiveSheet.Range("A1").EntireColumn.Hidden = True
And it worked. But I have added comments to other column headers which i get on hovering mouse over the cell. Am not getting the comments now..
Does deleting shapes have something to do with comments?

Actually i have added comments to other columns in my sheet. Comments come under activesheet.shapes so due to that i am unable to hide the column. Once I have set the placement for that it works perfectly
This code does the trick:
ActiveWorkbook.Sheets(sheetname).Activate
Dim sh As Shape
Dim rangeToTest As Range
Dim lRow As Long
Dim c As Range
lRow = ActiveSheet.Range("A" & ActiveSheet.Rows.Count).End(xlUp).Row
Set rangeToTest = ActiveSheet.Range("A1:A" & lRow)
For Each c In rangeToTest
For Each sh In ActiveSheet.Shapes
sh.Placement = xlMoveAndSize
Next sh
Next c
ActiveSheet.Range("A1").EntireColumn.Hidden = True

You can't use entirecolumn and hidden properties directly on columns, those properties works for Range() object only. Take Range("A1").EntireColumn.Hidden = True
Thanks
Nag

You should remove this line also
ActiveSheet.Columns(1).Select

Your code just works fine for me?? I'm in excel 2010, maybe you're not. Plugged it in as is and password protected the sheet as well. Comments or not made no difference, it will hide it whatever.

Two things
INTERESTING READ
Don't use Application.WorksheetFunction.CountA(Columns(1)) to find the last row. See THIS link on how to find the last row.
Is this what you are trying (UNTESTED)?
Option Explicit
Sub Sample()
Dim ws As Worksheet
Dim cmt As Comment
Dim iRow As Long, lRow As Long
Dim Password As String
'~~> Change as applicable
Password = "Blah Blah"
Set ws = ThisWorkbook.Sheets("Project")
With ws
.Unprotect Password
lRow = .Range("A" & .Rows.Count).End(xlUp).Row
For iRow = 1 To lRow
Set cmt = .Cells(iRow, 1).Comment
If Not cmt Is Nothing Then
.Cells(iRow + 1, 1) = .Cells(iRow, 1).Comment.Text
.Cells(iRow, 1).Comment.Delete
Else
'MsgBox "No Comments"
Debug.Print "No Comments"
End If
Next iRow
.Columns(1).EntireColumn.Hidden = True
.Protect Password
End With
End Sub

Related

Excel VBA Large Table, Add Comments Vlookup, After Hitting Command Button

I have a large table and the information I'm wanting to add comments to falls within Range(D11:CY148). I have two tabs - "Finish Matrix" (main) and "list" (hidden - has 2 columns).
I have two issues.
First issue - Code works to a degree, after I type my values within a cell it automatically adds comments based off info in another sheet. The problem is there is too many cells to be manually typing into and if I copy and paste the code doesn't run. I created a CommandButton and wanted it to refresh the entire table with comments depending if the cells had the values that fall within "list". I tried to create a call out to Worksheet_Change but to no avail. (I'm a beginner so it'll help if you explain)
Second issue - I'm assuming it'll get fixed with whatever suggestion that works. Occasionally after typing into a cell I would get an error. Can't remember the error name but it is one of the common ones, atm the error isn't popping up but surely it'll come back since I didn't do anything different to the code.
Private Sub Worksheet_Change(ByVal Target As Range)
If Intersect(Target, Columns("A:CX")) Is Nothing Then _
If Intersect(Target, Columns("CY")) Is Nothing Then Exit Sub
Dim lRow As Integer
lRow = Sheets("list").Range("A1").End(xlDown).Row
If Target.Value = vbNullString Then Target.ClearComments
For Each cell In Sheets("list").Range("A1:A" & lRow)
If cell.Value = Target.Value Then
Target.AddComment
Target.Comment.Text Text:=cell.Offset(0, 1).Value
End If
Next cell
End Sub
Thanks for any and all help!
You are basically missing the For Each Cell in Target part...
Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
Dim wsMain As Worksheet, wsList As Worksheet
Dim cell As Range
Dim vCommentList As Variant
Dim i As Long, lLastRow As Long
Dim sValue As String
On Error GoTo ErrHandler
Application.ScreenUpdating = False
Application.EnableEvents = False
Set wsMain = Target.Parent
Set Target = Intersect(Target, wsMain.Range("D11:CY148"))
If Target Is Nothing Then Exit Sub
Set wsList = wsMain.Parent.Sheets("list")
lLastRow = LastRow(1, wsList)
' Read Comment List into Variant (for speed)
vCommentList = wsList.Range("A1:B" & lLastRow)
Target.ClearComments
' This...For each Cell in Target...is what you were missing.
For Each cell In Target
sValue = cell
For i = 1 To UBound(vCommentList)
If sValue = vCommentList(i, 1) Then
AddComment cell, CStr(vCommentList(i, 2))
Exit For
End If
Next
Next
ErrHandler:
If Err.Number <> 0 Then Debug.Print Err.Description
Application.ScreenUpdating = True
Application.EnableEvents = True
End Sub
Proper way to find last row ...
Public Function LastRow(Optional Col As Integer = 1, Optional Sheet As Excel.Worksheet) As Long
If Sheet Is Nothing Then Set Sheet = Application.ActiveSheet
LastRow = Sheet.Cells(Sheet.Rows.Count, Col).End(xlUp).Row
End Function
Add Comment Sub the allows appending is needed...
Public Sub AddComment(Target As Range, Text As String)
If Target.Count = 1 Then
If Target.Comment Is Nothing Then
Target.AddComment Text
Else
Target.Comment.Text Target.Comment.Text & vbLf & Text
End If
End If
End Sub
Untested, but this will take all the values in Range(D11:CY148) and add a comment based on a lookup from Sheet "list".
Sub testy()
Dim arr As Variant, element As Variant
Dim i As Long, j As Long, listItems As Long, rwLast As Long, clLast As Long
Dim comm As String
Dim rng As Range, cell As Range
listItems = Sheets("list").Range("A1").End(xlDown).Row
rwLast = Cells.SpecialCells(xlCellTypeLastCell).Row ' Adjust to fit your needs
clLast = Cells.SpecialCells(xlCellTypeLastCell).Column 'Idem
Set rng = Sheets("list").Range("A1:A" & listItems)
arr = Range("D11:CY148").Value
With Worksheets("Finish Matrix")
For i = 1 To rwLast - 10 'Adjust to make it more general, this is pretty rough
For j = 1 To clLast - 3 'Idem
If i = 3 Then
End If
comm = ""
For Each cell In rng
If arr(i, j) = cell.Value Then
comm = comm & Chr(13) & cell.Offset(0, 1).Value
End If
Next cell
If Not (comm = "") Then
.Cells(10, 3).Offset(i, j).ClearComments
.Cells(10, 3).Offset(i, j).AddComment
.Cells(10, 3).Offset(i, j).Comment.Text Text:=comm
End If
Next j
Next i
End With
End Sub

Can't delete rows containing certain keyword within text

I have written a macro to remove rows containing certain text in it. If either of the keyword contains any text, the macro will delete the row. However, the macro doesn't work at all. Perhaps, i did something wrong in it. Hope somebody will help me rectify this. Thanks in advance.
Here is what I'm trying with:
Sub customized_row_removal()
Dim i As Long
i = 2
Do Until Cells(i, 1).Value = ""
If Cells(i, 1).Value = "mth" Or "rtd" Or "npt" Then
Cells(i, 1).Select
Selection.EntireRow.Delete
End If
i = i + 1
Loop
End Sub
The keyword within the text I was searching in to delete:
AIRLINE DRIVE OWNER mth
A rtd REPAIRS INC
AANA MICHAEL B ET AL
ABASS OLADOKUN
ABBOTT npt P
AIRLINE AANA MTH
ABASS REPAIRS NPT
Try like this.
What about Using Lcase.
Sub customized_row_removal()
Dim rngDB As Range, rngU As Range, rng As Range
Dim Ws As Worksheet
Set Ws = Sheets(1)
With Ws
Set rngDB = .Range("a2", .Range("a" & Rows.Count))
End With
For Each rng In rngDB
If InStr(LCase(rng), "mth") Or InStr(LCase(rng), "rtd") Or InStr(LCase(rng), "npt") Then
If rngU Is Nothing Then
Set rngU = rng
Else
Set rngU = Union(rngU, rng)
End If
End If
Next rng
If rngU Is Nothing Then
Else
rngU.EntireRow.Delete
End If
End Sub
VBA syntax of your Or is wrong,
If Cells(i, 1).Value = "mth" Or "rtd" Or "npt" Then
Should be:
If Cells(i, 1).Value = "mth" Or Cells(i, 1).Value = "rtd" Or Cells(i, 1).Value = "npt" Then
However, you need to use a string function, like Instr or Like to see if a certain string is found within a longer string.
Code
Option Explicit
Sub customized_row_removal()
Dim WordsArr As Variant
Dim WordsEl As Variant
Dim i As Long, LastRow As Long
Dim Sht As Worksheet
WordsArr = Array("mth", "rtd", "npt")
Set Sht = Worksheets("Sheet1")
With Sht
' get last row in column "A"
LastRow = .Cells(.Rows.Count, 1).End(xlUp).Row
For i = LastRow To 2 Step -1
For Each WordsEl In WordsArr
If LCase(.Cells(i, 1).Value) Like "*" & WordsEl & "*" Then
.Rows(i).Delete
End If
Next WordsEl
Next i
End With
End Sub
I try to make my code sample as I can if you have any question please ask
Private Sub remove_word_raw()
'PURPOSE: Clear out all cells that contain a specific word/phrase
Dim Rng As Range
Dim cell As Range
Dim ContainWord As String
'What range do you want to search?
Set Rng = Range("A2:A25")
'sub for the word
shorttext1 = "mth"
shorttext2 = "rtd"
shorttext3 = "npt"
'What phrase do you want to test for?
ContainWord1 = shorttext1
ContainWord2 = shorttext2
ContainWord3 = shorttext3
'Loop through each cell in range and test cell contents
For Each cell In Rng.Cells
If cell.Value2 = ContainWord1 Then cell.EntireRow.Delete
Next
For Each cell In Rng.Cells
If cell.Value2 = ContainWord2 Then cell.EntireRow.Delete
Next
For Each cell In Rng.Cells
If cell.Value2 = ContainWord3 Then cell.EntireRow.Delete
Next cell
End Sub

VBA Returns Error after Range.Find finds nothing

I have two worksheets in Excel, New Sheet and Old Sheet. I am trying to search in Column A of Old Sheet if the column contains each of the entries of Column A of New Sheet. I am using the following VBA code to search, but it returns an error on the second search (the non column header search). I have no idea what I'm doing wrong - any help is appreciated. Here is my code:
Sub Sample()
Dim lastRow As Integer
Dim i As Integer
Dim rng As Range
Dim searchrng As Range
Dim searchval As String
lastRow = Sheets("New One").Range("A65000").End(xlUp).Row
Sheets("Old One").Activate
Set searchrng = Sheets("Old One").Range("A1:A10000")
For i = 1 To lastRow
Sheets("New One").Activate
searchval = Sheets("New One").Cells(i, 1).Value
Set rng = searchrng.Find(searchval)
If Not rng Is Nothing Then
MsgBox "Found " & searchval & " in " & rng.Address
Else
Sheets("New One").Activate
Sheets("New One").Cells(i, 1).EntireRow.Interior.Color = vbRed
End If
Next i
End Sub
The error is always Run-time error '1004' - Method 'Find' of object 'Range' failed.
Avoid using .Select
Sub Sample()
Dim lastRow As Integer
Dim i As Integer
Dim rng As Range
Dim searchrng As Range
Dim searchval As String
Dim oldWS As Worksheet, newWS As Worksheet
Set oldWS = Worksheets("Old One")
Set newWS = Worksheets("New One")
lastRow = newWS.Range("A65000").End(xlUp).Row
Set searchrng = oldWS.Range("A1:A10000")
For i = 1 To lastRow
searchval = newWS.Cells(i, 1).Value
Set rng = searchrng.Find(searchval)
If Not rng Is Nothing Then
MsgBox "Found " & searchval & " in " & rng.Address
Else
newWS.Cells(i, 1).EntireRow.Interior.Color = vbRed
End If
Next i
End Sub
Does that work for you? I tested it in mine and it worked. Make sure the ranges you give are correct.
But, I agree with #ScottHoltzman - you can do this with Conditional Formatting, avoiding the use of VBA.
Thanks to everyone for the help.
I was able to get it to work by conditional formatting, thanks to Scott Holtzman for the idea. In the end, I used COUNTIF however, instead of IsError.
=COUNTIF('Old One'!$A:$A, 'New One'!$A1)=1
applied to Column A in 'New One' Worksheet.

search a worksheet for all value VBA Excel

I have a worksheet that has multiple value and what I would like to do is search say column "B" for a value and when it finds it to copy the complete row and paste it somewhere else. I have a similar function to do this but it stops after it finds the first one which is fine for the situation that I am using it in but for this case I need it to copy all that match. below is the code that im using at the moment that only gives me one value
If ExpIDComboBox.ListIndex <> -1 Then
strSelect = ExpIDComboBox.value
lastRow = wks1.range("A" & Rows.Count).End(xlUp).row
Set rangeList = wks1.range("A2:A" & lastRow)
On Error Resume Next
row = Application.WorksheetFunction.Match(strSelect, wks1.Columns(1), 0) ' searches the worksheet to find a match
On Error GoTo 0
If row Then
Thanks
I would suggest to load data into array first and then operate on this array instead of operating on cells and using Worksheet functions.
'(...)
Dim data As Variant
Dim i As Long
'(...)
If ExpIDComboBox.ListIndex <> -1 Then
strSelect = ExpIDComboBox.Value
lastRow = wks1.Range("A" & Rows.Count).End(xlUp).Row
'Load data to array instead of operating on worksheet cells directly - it will improve performance.
data = wks1.Range("A2:A" & lastRow)
'Iterate through all the values loaded in this array ...
For i = LBound(data, 1) To UBound(data, 1)
'... and check if they are equal to string [strSelect].
If data(i, 1) = strSelect Then
'Row i is match, put the code here to copy it to the new destination.
End If
Next i
End If
I have used the Range.Find() method to search each row. For each row of data which it finds, where the value you enter matches the value in column G, it will copy this data to Sheet2. You will need to amend the Sheet variable names.
Option Explicit
Sub copyAll()
Dim rngFound As Range, destSheet As Worksheet, findSheet As Worksheet, wb As Workbook
Dim strSelect As String, firstFind As String
Set wb = ThisWorkbook
Set findSheet = wb.Sheets("Sheet1")
Set destSheet = wb.Sheets("Sheet2")
strSelect = ExpIDComboBox.Value
Application.ScreenUpdating = False
With findSheet
Set rngFound = .Columns(7).Find(strSelect, LookIn:=xlValues)
If Not rngFound Is Nothing Then
firstFind = rngFound.Address
Do
.Range(.Cells(rngFound.Row, 1), .Cells(rngFound.Row, _
.Cells(rngFound.Row, .Columns.Count).End(xlToLeft).Column)).Copy
destSheet.Cells(destSheet.Cells(Rows.Count, 1).End(xlUp).Row + 1, 1).PasteSpecial Paste:=xlPasteAll
Set rngFound = .Columns(2).Find(strSelect, LookIn:=xlValues, After:=.Range(rngFound.Address))
Loop While firstFind <> rngFound.Address
End If
End With
Application.ScreenUpdating = True
End Sub
I've assumed you will have data between columns A:G?
Otherwise you can just amend the .Copy and .PasteSpecial methods to fit your requirements.
Thanks for your replys. I tired to use both methods but for some reason they did not seem to work. They did not give me an error they just did not produce anything.#mielk I understand what you mean about using an array to do this and it will be a lot faster and more efficent but I dont have enfough VBA knowledge to debug as to why it did not work. I tried other methods and finally got it working and thought it might be usefull in the future for anybody else trying to get this to work. Thanks once again for your answers :)
Private Sub SearchButton2_Click()
Dim domainRange As range, listRange As range, selectedString As String, lastRow As Long, ws, wks3 As Excel.Worksheet, row, i As Long
Set wks3 = Worksheets("Exceptions") '<----- WorkSheet for getting exceptions
If DomainComboBox.ListIndex <> -1 Then '<----- check that a domain has been selected
selectedString = DomainComboBox.value
lastRow = wks3.range("A" & Rows.Count).End(xlUp).row ' finds the last full row
Set listRange = wks3.range("G2:G" & lastRow) 'sets the range from the top to the last row to search
i = 2
'used to only create a new sheet is something is found
On Error Resume Next
row = Application.WorksheetFunction.Match(selectedString, wks3.Columns(7), 0) ' searches the worksheet to find a match
On Error GoTo 0
If row Then
For Each ws In Sheets
Application.DisplayAlerts = False
If (ws.Name = "Search Results") Then ws.Delete 'deletes any worksheet called search results
Next
Application.DisplayAlerts = True
Set ws = Sheets.Add(After:=Sheets(Sheets.Count)) 'makes a new sheet at the end of all current sheets
ws.Name = "Search Results" 'renames the worksheet to search results
wks3.Rows(1).EntireRow.Copy 'copys the headers from the exceptions page
ws.Paste (ws.Cells(, 1)) 'pastes the row into the search results page
For Each domainRange In listRange ' goes through every value in worksheet trying to match what has been selected
If domainRange.value = selectedString Then
wks3.Rows(i).EntireRow.Copy ' copys the row that results was found in
emptyRow = WorksheetFunction.CountA(ws.range("A:A")) + 1 ' finds next empty row
ws.Paste (ws.Cells(emptyRow, 1)) 'pastes the contents
End If
i = i + 1 'moves onto the next row
ws.range("A1:Q2").Columns.AutoFit 'auto fit the columns width depending on what is in the a1 to q1 cell
ws.range("A1:Q1").Cells.Interior.ColorIndex = (37) 'fills the header with a colour
Application.CutCopyMode = False 'closes the paste funtion to stop manual pasting
Next domainRange ' goes to next value
Else
MsgBox "No Results", vbInformation, "No Results" 'display messgae box if nothing is found
Exit Sub
End If
End If
End Sub
Thanks.
N.B. this is not the most efficent way of doing this read mielk's answer and the other answer as they are better if you can get them working.

Summary Sheet That Updates Source Sheets

I'd like to make a summary sheet that, if changed, changes the source sheets it is pulling from. The code I have so far aggregates all of my sheets on the summary sheet on the summary sheet's activation event. I am trying to have all of my other sheets updated on the deactivation event but it does not seem to be working. Here is the code I am working with:
Private Sub Worksheet_Deactivate()
Application.ScreenUpdating = False
Dim tabs As Variant
tabs = Array("BELD", "RMLD", "Pascoag", "Devens", "WBMLP", "Rowely", "AMP", "First Energy", "Dynegy", "APN", "MISC")
For j = 1 To UBound(tabs)
Sheets(tabs(j)).Select
Dim rng1 As Range
Dim Stri As String
For i = 3 To ActiveSheet.UsedRange.Cells(ActiveSheet.UsedRange.Cells.Count).Row
Stri = ActiveSheet.Cells(i, "A")
Set rng1 = Worksheets("Summary").Range("A:A").Find(Stri, , xlValues, xlWhole)
If Not rng1 Is Nothing Then
Sheets("Summary").Range(rng1.Address).EntireRow.Copy
ActiveSheet.Range("A" & i).EntireRow.Select
Selection.Insert Shift:=xlLeft
ActiveSheet.Range("A" & i + 1).EntireRow.Select
Selection.Delete Shift:=xlUp
Else
MsgBox strSearch & " not found"
End If
Next
ActiveSheet.Range("A" & 1).Select
Next
Application.ScreenUpdating = True
End Sub
I am very new to vba and this is my first post on stackoverflow so if I missed anything just let me know.
When you assign a variant array in that manner, you will end up with a zero-based array. You need to start at j = 0. As your own code currently is, it will never access the BELD worksheet.
Dim tabs As Variant
tabs = Array("BELD", "RMLD", "Pascoag", "Devens", "WBMLP", "Rowely", "AMP", "First Energy", "Dynegy", "APN", "MISC")
For j = 0 To UBound(tabs)
....
A more universal method would be using For j = LBound(tabs) To UBound(tabs) which does not matter whether your array is 1 or 0 based as you let each array describe its own properties through the LBound function and UBound function.
A more comprehensive rewrite of your routine would include getting rid of the .Select and .Activate methods and use direct worksheet and cell referencing in its place.
Private Sub Worksheet_Deactivate()
Dim rng1 As Range
Dim Stri As String, lr As Long, j As Long, i As Long
Dim tabs As Variant
On Error GoTo bm_Safe_exit
Application.ScreenUpdating = False
Application.EnableEvents = False
tabs = Array("BELD", "RMLD", "Pascoag", "Devens", "WBMLP", "Rowely", _
"AMP", "First Energy", "Dynegy", "APN", "MISC")
For j = LBound(tabs) To UBound(tabs)
With Sheets(tabs(j))
lr = .Cells.Find(Chr(42), After:=.Cells(1, 1), SearchDirection:=xlPrevious).Row
For i = 3 To lr
Stri = .Cells(i, "A").Value
If CBool(Len(Stri)) Then
On Error Resume Next
With Me.Range("A:A")
Set rng1 = .Find(What:=Stri, After:=.Cells(.Rows.Count), LookIn:=xlValues, LookAt:=xlWhole)
End With
On Error GoTo bm_Safe_exit
If Not rng1 Is Nothing Then
'clearing then copy/paste may be better than inserting, pasting and ultimately deleting old row
.Rows(i).Clear
rng1.EntireRow.Copy _
Destination:=.Range("A" & i)
Else
'maybe copy the data from the sheet back to the summary sheet if this occurs
MsgBox Stri & " on " & .Name & " not found on Summary"
End If
End If
Next
End With
Next
bm_Safe_exit:
Application.ScreenUpdating = True
Application.EnableEvents = True
End Sub
Since this is in the Summary worksheet's code sheets, the use of Me can be applied to the Summary worksheet object. Once you have set rng1 to the range returned by the find, it is no longer necessary to describe the worksheet it comes from as its Range .Parent property is carried with it.
See How to avoid using Select in Excel VBA macros for more methods on getting away from relying on select and activate to accomplish your goals.