Deleting certain month from certain year in Excel using VBA - vba

I am creating macro which will loop through column F and will delete month april from 2013. It seem that the macro is deleting all :-D. I dont know how to set it to delete only my criteria I tried (Month(Now) - 2). Mine date of format looks like DD/MM/YYYY.
Thank you for your help.
Sub Test1()
Dim rgFoundCell As Range
Dim toBeDeted As Range
Dim firstAddress
With Sheets("Sheet1").Range("F:F")
Set rgFoundCell = .Find(What:=(Month(Now) - 2))
If Not rgFoundCell Is Nothing Then
firstAddress = rgFoundCell.Address
Do
If toBeDeted Is Nothing Then
Set toBeDeted = rgFoundCell.EntireRow
Else
Set toBeDeted = Union(toBeDeted, rgFoundCell.EntireRow)
End If
Set rgFoundCell = .FindNext(rgFoundCell)
If rgFoundCell Is Nothing Then Exit Do
Loop While rgFoundCell.Address <> firstAddress
End If
End With
Application.ScreenUpdating = True
If Not toBeDeted Is Nothing Then _
toBeDeted.Delete ' Delete
End Sub

You can't use .Find in the way you think - it is only able to do text match or number match comparisons. This leaves you with having to cycle through each cell in the range and run your comparison explicitly on each cell
Sub Test1()
Dim toBeDeleted As Range
With Sheets("Sheet1").Range("F:F")
For Each c In .Cells
If Month(c.Value) = 3 And Year(c.Value) = 2013 Then
If toBeDeleted Is Nothing Then
Set toBeDeleted = c.EntireRow
Else
Set toBeDeleted = Union(toBeDeleted, c.EntireRow)
End If
End If
Next
End With
If Not toBeDeleted Is Nothing Then _
toBeDeleted.Delete ' Delete
End Sub
You might want to consider running the function on a more refined range than the full F column or use an end of data marker like checking for a blank row to stop the loop.

Try this:
Sub Test1()
On Error GoTo e
Application.ScreenUpdating = False
Dim rng As Range
Dim firstAddress
Set rng = Sheets("Sheet1").Range("F1", Sheets("Sheet1").Range("F1").End(xlDown))
Dim i As Long
i = 1
While i <= rng.Count
If Month(CDate(rng(i))) = 4 And Year(CDate(rng(i))) = 2014 Then
rng (i).EntireRow.Delete
Else
i = i + 1
End If
Wend
x:
Application.ScreenUpdating = True
Exit Sub
e:
MsgBox (Err.Description)
Resume x
End Sub
Maybe try to reduce the F:F range!!!

Related

Apply the Hidden behavior on the whole row

I have a file with multiple tables and by using the below code I am trying to access the rows which have specific terms using an array.
I successfully select the whole rows but when I try to apply the Hidden behavior on the whole row then VBA through an error.
Getting error on below the line
Selection.Font.Hidden = True
Below is my whole code
Sub test()
Dim SearchArr() As Variant, Cnt As Integer, Arrcnt As Integer
Dim WrdApp As Object, FileStr As String, WrdDoc As Object, aRng As Range
Dim TblCell As Variant
Set WrdApp = CreateObject("Word.Application")
WrdApp.Visible = True
'********** change address to suit
FileStr = "C:\Users\krishna.haldunde\Downloads\DE\DE\International_DE.docx"
Set WrdDoc = WrdApp.Documents.Open(FileStr)
SearchArr = Array("French", "Spanish")
'loop tables
For Cnt = 1 To WrdApp.ActiveDocument.Tables.Count
'loop search word
For Arrcnt = LBound(SearchArr) To UBound(SearchArr)
'loop through table cells
For Each TblCell In WrdApp.ActiveDocument.Tables(Cnt).Range.Cells
Set aRng = TblCell.Range
'If TblCell.RowIndex = WrdApp.ActiveDocument.Tables(Cnt).Rows.Count Then Exit For
If InStr(LCase(aRng), LCase(SearchArr(Arrcnt))) Then
aRng.Select
Selection.Font.Hidden = True
End If
Next TblCell
Next Arrcnt
Next Cnt
End Sub
Can anyone help me out to understand where i am doing issue so, i can rectify it.
I think it's more effective to reduce the row height to an exact minimum value.
Something like this works for me.
Sub Test()
SearchArr = Array("sdg", "sdh", "dsf")
'loop tables
For Cnt = 1 To ActiveDocument.Tables.Count
'loop search word
For Arrcnt = LBound(SearchArr) To UBound(SearchArr)
'loop through table cells
For Each tblCell In ActiveDocument.Tables(Cnt).Range.Cells
Set aRng = tblCell.Range
If InStr(LCase(aRng), LCase(SearchArr(Arrcnt))) Then
ActiveDocument.Tables(Cnt).Rows(tblCell.RowIndex).HeightRule = wdRowHeightExactly
ActiveDocument.Tables(Cnt).Rows(tblCell.RowIndex).Height = 1
End If
Next tblCell
Next Arrcnt
Next Cnt
End Sub

VBA search for value on next sheet

is there I way for searching a value on the next sheet (ActiveSheet.Next.Activate) without jumping on to it?
Here the whole Code:
the problem is, it jumps to the next sheet even if there is no searched value.
Dim ws As Worksheet
Dim Loc As Range
Dim StrVal As String
Dim StrRep As String
Dim i As Integer
Private Sub CommandButton1_Click()
i = 1
Call Replacing
End Sub
Private Sub CommandButton2_Click()
i = 2
Call Replacing
End Sub
Public Sub Replacing()
StrVal = Userform1.Textbox1.Text
StrRep = Me.Textbox1.Text
if Trim(StrVal) = "" Then Exit Sub
Dim fstAddress As String
Dim nxtAddress As String
For Each ws In ThisWorkbook.Worksheets
With ws
Set Loc = .Cells.Find(what:=StrVal)
fstAddress = Loc.Address
If Not Loc Is Nothing Then
If Not StrRep = "" And i = 1 Then
Loc.Value = StrRep
Set Loc = .Cells.FindNext(Loc)
ElseIf i = 2 Then Set Loc = Range(ActiveCell.Address)
Set Loc = .Cells.FindNext(Loc)
nxtAddress = Loc.Address
If Loc.Address = fstAddress Then
ActiveSheet.Next.Activate '****Here it should jump only if found something on the next sheet****
GoTo repeat
nxtAddress = Loc.Address
End If
If Not Loc Is Nothing Then Application.Goto ws.Range(nxtAddress), False
End If
i = 0
End If
End With
Set Loc = Nothing
repeat:
Next ws
End Sub
the variable "i" which switches between the values 0, 1 and 2 is bound to two buttons. these buttons are "Replace" and "Skip (to next found value)".
This code asks on each occurrence of StrVal whether you want to replace the value or skip it.
I found a problem checking if Found_Address = First_Found_Address:
If you've replaced the value in in First_Found_Address it won't find that address again and miss the starting point in the loop.
Also the original source of the code stops at the last value using Loop While Not c Is Nothing And c.Address <> firstAddress. The problem here is that if the value in c is being changed eventually c will be Nothing but it will still try and check the address of c - causing an error (Range Find Method).
My solution to this is to build up a string of visited addresses on the sheet and checking if the current address has already been visited using INSTR.
I've included the code for calling from a button click or from within another procedure.
Private Sub CommandButton1_Click()
FindReplace Userform1.Textbox1.Text, 1
End Sub
Private Sub CommandButton2_Click()
FindReplace Userform1.Textbox1.Text, 1, Me.Textbox1.Text
End Sub
Sub Test()
FindReplace "cd", 1, "ab"
End Sub
Sub FindReplace(StrVal As String, i As Long, Optional StrRep As String = "")
Dim ws As Worksheet
Dim Loc As Range
Dim fstAddress As String
Dim bDecision As Variant
For Each ws In ThisWorkbook.Worksheets
'Reset the visited address list on each sheet.
fstAddress = ""
With ws
Set Loc = .Cells.Find(what:=StrVal, LookIn:=xlValues, LookAt:=xlWhole, SearchDirection:=xlNext)
If Not Loc Is Nothing Then
Do
fstAddress = fstAddress & "|" & Loc.Address
Loc.Parent.Activate 'Activate the correct sheet.
Loc.Activate 'and then the cell on the sheet.
bDecision = MsgBox("Replace value?", vbYesNo + vbQuestion, "Replace or Select value?")
If bDecision = vbYes Then
Loc = StrRep 'Raise the blade, make the change.
'Re-arrange it 'til it's sane.
End If
Set Loc = .Cells.FindNext(Loc)
If Loc Is Nothing Then Exit Do
Loop While InStr(fstAddress, Loc.Address) = 0
End If
End With
Next ws
End Sub

How can I adapt my VBA to include a second series of data

When I use the below macro it only works for one series data set. How can I adapt it so that I can include multiple series?
Currently if I try and use it to label a second set it will delete the first one and so on...
Thanks in advance
Sub AddXYLabels()
If Left(TypeName(Selection), 5) <> "Chart" Then
MsgBox "Please select the chart first."
Exit Sub
End If
Set StartLabel = _
Application.InputBox("Click on the cell containing the first(top) label", Type:=8)
Application.ScreenUpdating = False
For Each pt In ActiveChart.SeriesCollection(1).Points
pt.ApplyDataLabels xlDataLabelsShowValue
pt.DataLabel.Caption = StartLabel.Value
Set StartLabel = StartLabel.Offset(1)
Next
End Sub
Your code is not working for rest of the series since you have hard coded the range for only one series
For Each pt In ActiveChart.SeriesCollection(1).Points
Please try this
Sub AddXYLabels()
If Left(TypeName(Selection), 5) <> "Chart" Then
MsgBox "Please select the chart first."
Exit Sub
End If
Dim mySeries As Series
Dim seriesCol As SeriesCollection
Dim I As Integer
I = 1
Set seriesCol = ActiveChart.SeriesCollection
For Each mySeries In seriesCol
Set mySeries = ActiveChart.SeriesCollection(I)
With mySeries
.ApplyDataLabels xlDataLabelsShowValue
End With
I = I + 1
Next
End Sub

VBA Record date of row change in specific column

I'm trying to automatically update the "Updated" column of an excel spreadsheet when any cell of that specific row changes to today's date. I was able to do this by hard-coding where the "Updated" column header would be, however, it is now necessary to search for that column header as it may move.
The code I am trying to implement works but immediately gives me the error Automation error - The object invoked has disconnected from it's clients.
Any help would be appreciated. Here is the code I have currently:
Private Sub Worksheet_Change(ByVal Target As Range)
If Not Intersect(Target, Range("A:DX")) Is Nothing Then
Dim f As Range
Set f = ActiveSheet.Range("A1:DD1").Find("Updated", lookat:=xlWhole)
' f.Row = Range(Target).Row
If Not f Is Nothing Then
Range(Split(f.Address, "$")(1) & Target.Row).Value = Now
Else
MsgBox "'Updated' header not found!"
End If
End If
End Sub
You got into an endless loop.
Try this:
Private Sub Worksheet_Change(ByVal Target As Range)
If Not Intersect(Target, Range("A:DX")) Is Nothing Then
Dim f As Range
Set f = ActiveSheet.Range("A1:DD1").Find("Updated", lookat:=xlWhole)
' f.Row = Range(Target).Row
If f Is Nothing Then
MsgBox "'Updated' header not found!"
ElseIf Intersect(Target, f.EntireColumn) Is Nothing Then
Intersect(Target.EntireRow, f.EntireColumn).Value = Now
' Else
' MsgBox "We entered this function again because the row above updated the Updated column", vbInformation, "False alarm"
End If
End If
End Sub
To understand what happens,
Uncomment the else and MsgBox
Put a breakpoint on the MsgBox
When you hit it, press [ctrl]-L
In a case such as this, I run into far fewer problems when I simply loop through the available cells to find the column header. Using the .Find method also works, but is less "tunable" to my needs in a custom application.
Public Function FindColumn(header As String) As Long
Dim lastCol As Long
Dim headerCol As Long
Dim i As Long
Dim sh As Worksheet
Set sh = ThisWorkbook.Sheets("VTO2 Labor")
lastCol = sh.Cells(1, sh.Columns.Count).End(xlToLeft).Column
headerCol = 0
For i = 1 To lastCol
If sh.Cells(1, i).Value = header Then
headerCol = i
End If
Next i
FindColumn = headerCol
End Function
It isn't clear on whether the Updated column header could be in row 1 or if it will always be in row 1, just not in the same location.
Private Sub Worksheet_Change(ByVal Target As Range)
If Not Intersect(Target, Range("A:DX")) Is Nothing Then
On Error GoTo bm_SafeExit
'TURN OFF EVENTS IF YOU ARE GOING TO WRITE A VALUE INTO THE WORKSHEET!
Application.EnableEvents = False
Dim uCol As Long, f As Range
If Application.CountIf(Rows(1), "updated") Then
uCol = Application.Match("updated", Rows(1), 0)
For Each f In Intersect(Target, Range("A:DX"))
If f.Row > 1 Then _
Cells(f.Row, uCol) = Now
Next f
Else
MsgBox "'Updated' header not found!"
End If
End If
bm_SafeExit:
Application.EnableEvents = True
End Sub
That should survive multiple updates (e.g. when pasting values). The problem I see is that is the Updated column is being shifted around, presumably through inserting columns or the like, then the change routine is going to run.

Cannot use named range when it is empty

I have a named range lstVendors that refers to: =OFFSET(Data!$W$2,0,0,COUNTA(Data!$W$2:$W$400),1). I want this range to be populated when the workbook opens. I have the following code for this:
Private Sub Workbook_Open()
Application.WindowState = xlMaximized
Dim rslt()
Dim i As Integer
Dim n As Integer
Dim startRng As Range
Dim DropDown1 As DropDown
ThisWorkbook.Sheets("Dashboard").Shapes("TextBox 6").Visible = False
' Range("lstVendors").Offset(0, 0).Value = "Please Select..."
' Set DropDown1 = ThisWorkbook.Sheets("Dashboard").DropDowns("Drop Down 1")
' DropDown1.Value = 1
On Error Resume Next
If Not IsError(Range("lstVendors")) Then
Range("lstVendors").ClearContents
End If
On Error GoTo 0
rslt = Application.Run("SQLite_Query", "path/to/my/sqlite", "SELECT PROGRAM_ID FROM VENDOR;")
Set startRng = Range("lstVendors")
i = 0
For n = 2 To UBound(rslt)
Range("lstVendors").Offset(i, 0).Value = rslt(n)(0)
i = i + 1
Next n
End Sub
It errors on the Set startRng = Range("lstVendors"). I know this is because there's nothing in the range when I'm trying to set it, because if I put one entry into the named range, the set works, however, I need it populated by the sqlite query on each open as the data changes.
Any suggestions much appreciated.
Try this. You have a dynamic range that doesn't evaluate after you clear the contents. To avoid this, there are probably several ways, but easy to simply hardcode the startRange variable so that it always points to Data!$W$2 address, which is (or rather, will become) the first cell in your lstVendors range.
Private Sub Workbook_Open()
Dim rslt()
Dim i As Integer
Dim n As Integer
Dim startRng As Range
Dim DropDown1 As DropDown
Dim rngList As Range
'// Define your startRange -- always will be the first cell in your named range "lstVendors"
' hardcode the address because the dynamic range may not evalaute.
Set startRange = Sheets("Data").Range("W2")
'// Empty th lstVendors range if it exists/filled
On Error Resume Next
Range("lstVendors").Clear
On Error GoTo 0
'// Run your SQL query
rslt = Application.Run("SQLite_Query", "path/to/my/sqlite", "SELECT PROGRAM_ID FROM VENDOR;")
i = 0
'// Print results to the Worksheet, beginning in the startRange cell
For n = 2 To UBound(rslt)
'Increment from the startRange cell
startRange.Offset(i, 0).Value = rslt(n)(0)
i = i + 1
'Verify that "lstVendors" is being populated
Debug.Print Range("lstVendors").Address
Next n
End Sub
Thanks for the suggestions. Here is what I ended up doing in order to get around my problem. It involves adding something I didn't specify would be ok in my original question, so David's answer is great if what I did isn't an option. I first populated the first two cells in my named range with "Please Select..." and "All". In Sub Workbook_Open() we do this:
Private Sub Workbook_Open()
Application.WindowState = xlMaximized
Dim rslt()
Dim i As Integer
Dim n As Integer
Dim startRng As Range
Dim DropDown1 As DropDown
' Disable our not found message
ThisWorkbook.Sheets("Dashboard").Shapes("TextBox 6").Visible = False
' Set our start range to our named range
Set startRng = Range("lstVendors")
' Grab all vendor names
rslt = Application.Run("SQLite_Query", "path/to/my/sqlite", "SELECT PROGRAM_ID FROM VENDOR;")
' Print result. Skip first two rows as constants "Please Select..." and "All" are populated there
i = 2
For n = 2 To UBound(rslt)
startRng.Offset(i, 0).Value = rslt(n)(0)
i = i + 1
Next n
End Sub
Then we will create Sub Workbook_BeforeClose:
Private Sub Workbook_BeforeClose(Cancel As Boolean)
' Disable the save changes dialog. This workbook will be locked up for display only. No need to confuse the user.
Application.DisplayAlerts = False
' Clear everything below the "Please Select..." and "All" cells in the named range
On Error Resume Next
Range("lstVendors").Offset(2, 0).ClearContents
On Error GoTo 0
' Save the changes to the named range
ThisWorkbook.Save
Application.DisplayAlerts = True
End Sub
This information is going to populate a drop down, so having Please Select and All hardcoded into the named range is acceptable for me. If that stipulation doesn't work for someone else looking at this in the future, please use David's suggestion! Thanks again!