I have a pivot table where I have applied a date filter:
I am looking for a way to display the filter information in a cell.
e.g. between 1/1/2015 and 10/3/2015
I have tried the following to just get it to display the information in a message box:
Sub DisplayRange()
With ActiveSheet.PivotTables("OrdersPerSlot").PivotFields("PickDate").PivotFilters(1)
MsgBox "FilterType: " & .FilterType & vbCr _
& "Value1: " & .value1 & vbCr _
& "Value2: " & .value2
End With
End Sub
I get the following error:
Next I moved the code into the "ThisWorkBook" Object in case there was some referencing issue and got this error:
I think you need VBA for this. By running the Macro Recorder while adding a date filter I came up with:
Sub GetPivotFilterDates()
Dim pvt As Excel.PivotTable
Dim pvtField As Excel.PivotField
Set pvt = Worksheets(1).PivotTables(1)
Set pvtField = pvt.PivotFields("Date Range")
With pvtField.PivotFilters(1)
If .FilterType = xlDateBetween Then
Worksheets(1).Range("A1").Value = "Filter is between " & .Value1 & " and " & .Value2
End If
End With
End Sub
Related
Basically, I have an Excel Formatted Table called "TestTable" in my activesheet. That's the only table in that sheet. I'm trying to convert it to a normal range. From looking up online, this should be simple, all I have to do is Unlist that table object.
However, my VBA code is throwing an error. Any pointers in the right direction would be greatly appreciated.
Sub ConverToNormalRange()
Dim objListObj As ListObject
Set objListObj = ActiveSheet.ListObjects(1)
objListObj.Unlist
End Sub
When I run the above macro, I get the following error:
Convert First Table to a Range
Sub ConvertToRange()
Const ProcName As String = "ConvertToRange"
On Error GoTo ClearError
With ActiveSheet ' improve!
If .ListObjects.Count > 0 Then
Dim tblName As String
With .ListObjects(1)
tblName = .Name
.Unlist
End With
MsgBox "Table '" & tblName & "' converted to a range.", _
vbInformation
Else
MsgBox "No table found in worksheet '" & .Name & "'.", _
vbExclamation
End If
End With
ProcExit:
Exit Sub
ClearError:
Debug.Print "'" & ProcName & "' Run-time error '" _
& Err.Number & "':" & vbLf & " " & Err.Description
Resume ProcExit
End Sub
I tried converting the table manually and it wasn't doing anything either. So then I figured it wasn't a VBA problem. It turns out that I had connections open in Power Query, and it was preventing the table from converting back to normal range.
I have an Outlook VBA function that takes a Selection and processes its Items.
I want it to Select again whatever Selection existed previously.
I guessed I have to store the initial selection. After processing a first item, the Selection becomes empty, so I would use AddToSelection to add one item at a time.
But I could not avoid getting error 438.
From official documentation, the only possible source of error I see is any listed in "Under the following conditions, Outlook returns an error when you call the AddToSelection method:"
But I think none of those apply.
What are possible sources of error, and how can I systematically assess which is my case?
How can I end with a Selection of the same original items?
My function (here applied to a Selection with a single item):
Sub MoveAppt()
' Move selected appointment a given number of days within the Calendar
Dim sel As Outlook.Selection, xpl As Explorer
Dim oOlAppt As Outlook.AppointmentItem
Set xpl = Application.ActiveExplorer
Set sel = xpl.Selection
Set oOlAppt = sel.Item(1)
Dim newStart As Date
Dim ndays As Integer
ndays = 7
newStart = MoveAppointment(oOlAppt, ndays)
Debug.Print "Count = " & xpl.Selection.Count ' THIS GIVES 0, CONFIRMING AN EMPTY Selection
If (xpl.IsItemSelectableInView(oOlAppt)) Then ' <----- THIS RETURNS True ...
xpl.AddToSelection oOlAppt ' <----- ... BUT THIS GIVES ERROR -2147467259 (80004005)
Else
Debug.Print "Object is not selectable"
End If
End Sub
Function MoveAppointment(ByRef oOlAppt As Outlook.AppointmentItem, ByVal ndays As Integer) As Date
' Move an Outlook.AppointmentItem a given number of days within the Calendar
With oOlAppt
Dim currStart As Date, newStart As Date
currStart = .Start
newStart = DateAdd("d", ndays, currStart)
.Start = newStart
.Save
End With
MoveAppointment2 = newStart
End Function
EDIT:
Removing parenthesis about the argument of AddToSelection changed the error to that indicated in the code.
So I tried: 1) setting a breakpoint at that line, 2) when the breakpoint is hit, going in the calendar view to the week of newStart, where the moved item is now, 3) continuing. This runs ok, so it seems to answer the question.
As for how to re-select the original items, I guess I should: 1) determine the min and max dates among all original items, 2) set the CalendarView to cover those dates, 3) loop through all items in the original selection and AddToSelection them.
I wouldn't know if there is anything simpler.
Re: How can I end with a Selection of the same original items?
With Set sel = xpl.Selection, sel is a Selection of the same original items.
Sub MoveAppt_SelOnly()
' Move selected appointment a given number of days within the Calendar
Dim xpl As Explorer
Dim sel As Selection
Dim ndays As Long
Set xpl = ActiveExplorer
If xpl.Selection(1).Class = olAppointment Then
If xpl.Selection(1).subject = "test" Then
Debug.Print
Debug.Print "xpl.Selection.count ....: " & xpl.Selection.count
Debug.Print "xpl.Selection(1).subject: " & xpl.Selection(1).subject
Debug.Print "xpl.Selection(1).start..: " & xpl.Selection(1).Start
Set sel = xpl.Selection
Debug.Print "sel(1).subject..........: " & sel(1).subject
Debug.Print "sel(1).start............: " & sel(1).Start
ndays = 7
MoveAppointment sel(1), ndays
Debug.Print
Debug.Print "xpl.Selection.count ....: " & xpl.Selection.count
Debug.Print "sel(1).subject..........: " & sel(1).subject
Debug.Print "sel(1).start.........new: " & sel(1).Start
' For testing. Be sure the item is not in the view after this first move
' otherwise you do not lose track of xpl.Selection.
MsgBox "The moved item should not be in the view." & vbCr & _
"xpl.Selection.count ....: " & xpl.Selection.count & vbCr & _
"sel(1).subject..........: " & sel(1).subject & vbCr & _
"sel(1).start.........new: " & sel(1).Start
Debug.Print
' If you see zero here it does not matter
Debug.Print "xpl.Selection.count ....: " & xpl.Selection.count
Debug.Print "sel(1).subject..........: " & sel(1).subject
Debug.Print "sel(1).start.........new: " & sel(1).Start
' Return the item to where it started, using sel,
' a "Selection of the same original items".
MoveAppointment sel(1), ndays * (-1)
MsgBox "The moved item should be in the view now." & vbCr & _
"xpl.Selection.count ....: " & xpl.Selection.count & vbCr & _
"sel(1).subject..........: " & sel(1).subject & vbCr & _
"sel(1).start....original: " & sel(1).Start
Debug.Print
' If you see zero here it does not matter
Debug.Print "xpl.Selection.count ....: " & xpl.Selection.count
Debug.Print "sel(1).subject..........: " & sel(1).subject
Debug.Print "sel(1).start....original: " & sel(1).Start
End If
End If
End Sub
Sub MoveAppointment(ByRef oOlAppt As AppointmentItem, ByVal ndays As Long)
' Move an AppointmentItem a given number of days within the Calendar
Dim newStart As Date
With oOlAppt
oOlAppt.Start = DateAdd("d", ndays, oOlAppt.Start)
.Save
End With
End Sub
Trying to use an Excel-macro that will automatically save the workbook once certain cells are filled in. The macro will check when changes are made to specific cells, then use variable data to save the workbook through a folder system organized by year and quarter, while giving the Workbook a name based on the Current date and a cell number. The macro will also check to see if the network path (it being on a server) is connected, and if not, exit the sub. I am getting a compile error "Expected: end of statement" at
Set mTitle = Year(Now)," & . & ", Month(Now), " &.& ", Day(Now), " & - & ", ActiveWorkbooks.Sheets("Control").Cells(1, "C")
I want to save the workbook with the following format: Year.Month.Day - CellValue, but it looks like VBA doesn't like periods. How can I solve this? Full code below.
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Dim cYear As String
Dim Quarter As String
Dim fdObj As Object
Dim mTitle As String
Dim sCheck
Application.ScreenUpdating = False
Set cYear = Year(Now)
Set Quarter = (Month(Now) + 2) \ 3
Set fdObj = CreateObject("Scripting.FileSystemObject")
sCheck = "S:\Estimating Data\Estimates\test.txt"
Set mTitle = Year(Now)," & . & ", Month(Now), " &.& ", Day(Now), " &.& ", ActiveWorkbooks.Sheets("Control").Cells(1, "C")
If Intersect(Target, Range("C1:C5")) Is Nothing Then
Exit Sub
Else
If WorksheetFunction.CountA(Range("C1:C5")) = 0 Then
Exit Sub
Else
Shell ("Net View \\S:\ > " & vsFileName)
If FileLen(vsFileName) = 0 Then
Exit Sub
Else
If fdObj.FolderExists("S:\Estimating Data\Estimates\" & cYear & "\""Q" & Quarter & ".*xlsm") Then
ActiveWorkbook.SaveAs Filename:="S:\Estimating Data\Estimates\" & cYear & "\""Q" & Quarter & "\" & mTitle & ".*xlsm"
Else
fdObj.CreateFolder ("S:\Estimating Data\Estimates\" & cYear & "\""Q" & Quarter & ".*xlsm")
End If
End If
End If
End If
End Sub
I have an excel-workbook containing two worksheets, and I have written code to transfer data from sheet No.1 to sheet No.2.
What I need is to include a condition that checks if the column G does not contain a certain value. In that case I would like a MsgBox to display "Check..".
The interested range in the Sheet 1 is (A3:J50), so the condition would interest cells G3 to G50.
My current code is:
Sub kk()
Dim lastrow As Integer
lastrow = [b50].End(xlUp).Row
Range("b3:J" & lastrow).Copy Sheets("Daily Rec.").Range("b" & Sheets("Daily Rec.").[b1000].End(xlUp).Row + 1)
Range("b3:j" & lastrow).ClearContents
MsgBox ("Date Posted")
Sheets("Daily Rec.").Activate
MsgBox ("Check..")
End Sub
please advice
This should help get you started.
But like others have mentioned, we need more info to help.
Sub Okay()
Dim source As Range
Dim target As Range
Dim found As Range
Dim cell As Range
Set source = ThisWorkbook.Worksheets("Sheet 1").Range("A3:J50")
Set target = ThisWorkbook.Worksheets("Sheet 2").Range("G3:G50")
For Each cell In source.Cells
Set found = target.Find(cell.Value)
If found Is Nothing Then
MsgBox "Check.." & vbNewLine _
& "Cell [" & cell.Address(0, 0) & "] on sheet [" & cell.Parent.Name & "]" _
& vbNewLine _
& "was not found within " & vbNewLine _
& "cell range of [" & target.Address(0, 0) & "] on sheet [" & target.Parent.Name & "]"
End If
Next cell
End Sub
I'm quite new to excel and have been trying to get this Countif formula to work for a while now. I want it to count from the 12th row in column AN p till the last used row. I am very close now but when I run the macro it gives me a REF error.
Sub Date1()
'
' Enter Date
'
Range("B15") = InputBox("Enter Date")
Dim LR As Long
LR = Sheets("Design Risk Scoring Sheet").Range("AN" & Rows.count).End(xlUp).Row
Range("B16").FormulaR1C1 = _
"=COUNTIF('Design Risk Scoring Sheet'!R[-4]C[38]:RC[38](" & LR & "), ""<"" & R[-1]C )"
End Sub
This is what i get in the formula cell when I run the macro
=COUNTIF('Design Risk Scoring Sheet'!AN12:AN16(163), "<" & B15 )
It should ideally be AN163 instead of 16. I have tried removing RC[38] and putting AN instead but i get AN(163) which gives a #NAME error and if i remove the brackets in (" & LR & ") then I get single quotation marks in the formula :
=COUNTIF('Design Risk Scoring Sheet'!AN12:'AN163', "<" & B15 )
I dont know how to fix this problem?
Alternate:
Sub Date1()
Dim sDate As String
sDate = InputBox("Enter Date", "Date Entry", Format(Now, "m/d/yyyy"))
If Len(sDate) = 0 Then Exit Sub 'Pressed cancel
If Not IsDate(sDate) Then
MsgBox "[" & sDate & "] is not a valid date.", , "Exiting Macro"
Exit Sub
End If
Range("B15").Value2 = DateValue(sDate)
Range("B16").Formula = "=COUNTIF(AN12:AN" & Cells(Rows.Count, "AN").End(xlUp).Row & ",""<""&B15)"
End Sub
Try This..
Range("B16").FormulaR1C1 = _
"=COUNTIF('Design Risk Scoring Sheet'!R[-4]C[38]:RC[38](" & LR & "), < & R[-1]C )"