Excel listing named range in a worksheet and get the value - excel

How to obtain a list of named range exist in a specific worksheet that start with particular string (for example all named range that start with total) and grab the value? I am trying to do Sub Total and Grand Total of accommodation cost based on the date. I will assign an unique name for each Sub Total based on the Date group. Then, I have a button that need to be clicked when it finishes to calculate the Grand Total based on the Named Range that I've assigned uniquely to each Sub Total.
Below is the code I wrote to do the Grand Total:
Sub btnTotal()
Dim Total, LastRowNo As Long
LastRowNo = ActiveSheet.UsedRange.Row + ActiveSheet.UsedRange.Rows.Count
Total = 0
For Each N In ActiveWorkbook.Names
Total = Total + IntFlight.Range(N.Name).Value
Next N
IntFlight.Range("$P" & LastRowNo).Select
Selection.NumberFormat = "$* #,##0.00;$* (#,##0.00);$* ""-""??;#"
With Selection
.Font.Bold = True
End With
ActiveCell.FormulaR1C1 = Total
End Sub
Note: the IntFlight from "Total = Total + IntFlight.Range(N.Name).Value" is the name of my worksheet.
The only problem with above code, it will looking all named range exist in the workbook. I just need to find named range exist in one particular worksheet, which start with given string and the row number (total26: means Sub Total from row 26) and then grab the value to be sum-ed as Grand Total.
Any ideas how to do this? Been spending 2 days to find the answer.
Thanks heaps in advance.
EDIT 1 (Solution Provided by Charles Williams with help from belisarius):
This is what I have done with the code from Charles Williams:
Option Explicit
Option Compare Text
Sub btnIntFlightsGrandTotal()
Dim Total, LastRowNo As Long
LastRowNo = FindLastRowNo("International Flights")
Dim oNM As Name
Dim oSht As Worksheet
Dim strStartString As String
strStartString = "IntFlightsTotal"
Set oSht = Worksheets("International Flights")
For Each oNM In ActiveWorkbook.Names
If oNM.Name Like strStartString & "*" Then
If IsNameRefertoSheet(oSht, oNM) Then
Total = Total + Worksheets("International Flights").Range(oNM.Name).Value
End If
End If
Next oNM
IntFlights.Range("$P" & LastRowNo).Select
Selection.NumberFormat = "$* #,##0.00;$* (#,##0.00);$* ""-""??;#"
With Selection
.Font.Bold = True
End With
ActiveCell.FormulaR1C1 = Total
End Sub
Function FindLastRowNo(SheetName As String) As Long
Dim oSheet As Worksheet
Set oSheet = Worksheets(SheetName)
FindLastRowNo = oSheet.UsedRange.Row + oSheet.UsedRange.Rows.Count
End Function
Thank you all for your help. Now, I need to come up with my own version for this script.

Here is some code that checks if a Defined Name starts with a string and refers to a range within the used range of a given worksheet and workbook.
Option Explicit
Option Compare Text
Sub FindNames()
Dim oNM As Name
Dim oSht As Worksheet
Dim strStartString As String
strStartString = "Total"
Set oSht = Worksheets("TestSheet")
For Each oNM In ActiveWorkbook.Names
If oNM.Name Like strStartString & "*" Then
If IsNameRefertoSheet(oSht, oNM) Then
MsgBox oNM.Name
End If
End If
Next oNM
End Sub
Function IsNameRefertoSheet(oSht As Worksheet, oNM As Name) As Boolean
Dim oSheetRange As Range
IsNameRefertoSheet = False
On Error GoTo GoExit
If Not oSht Is Nothing Then
If Range(oNM.Name).Parent.Name = oSht.Name And _
Range(oNM.Name).Parent.Parent.Name = oSht.Parent.Name Then
Set oSheetRange = oSht.Range("A1").Resize(oSht.UsedRange.Row + oSht.UsedRange.Rows.Count - 1, oSht.UsedRange.Column + oSht.UsedRange.Columns.Count - 1)
If Not Intersect(Range(oNM.Name), oSheetRange) Is Nothing Then IsNameRefertoSheet = True
Set oSheetRange = Nothing
End If
End If
Exit Function
GoExit:
End Function

The following function will output all the names and their totals in your Workbook.
I think it is the basic block you need to get your code running.
Sub btnTotal()
For Each N In ActiveWorkbook.Names
MsgBox N.Name + " " + CStr(Application.WorksheetFunction.Sum(Range(N)))
Next N
End Sub
Edit
Answering your comment:
Define your names in this way:
Then (and only then) the following code works:
Sub btnTotal()
For Each N In ActiveSheet.Names
If (InStr(N.Name, "!Total") <> 0) Then
MsgBox N.Name + " " + CStr(Application.WorksheetFunction.Sum(Range(N)))
End If
Next N
End Sub
If you do not define the scope of the names correctly you need a lot of extra work in your code.
Edit
As you forgot to mention that you are still working with Excel 2003, here you will find an addin to manage name scoping in that version. See screen cap below
HTH

Related

Sort Excel worksheets based on name, which is a date

So I've got this Excel workbook that has some macro's. Users are presented with a button to either create a worksheet with the current date as name, or enter a date manually and that worksheet will be created.
Now the issue: The worksheet has two sheet ('Initial' and 'Version') that must be first and last. However, all worksheets created in between should be sorted on date everytime a new sheet is created. And I mean sorted on date, the sheets are 'DD-MM-YY' so e.g. I could have names like '1-11-21', '2-11-21', '11-11-21' and '21-11-21' in the same workbook and it should be sorted ascending.
Any suggestions? A normal sort just messes things up I found (1-11-21 and 11-11-21, followed by '2-11-21' and '21-11-21'....
Thanks,
Jasper
Sorting sheets of a workbook is rather easy, there a numerous examples out there, looking more or less like this:
Sub SortSheets(Optional wb As Workbook = Nothing)
If wb Is Nothing Then Set wb = ActiveWorkbook ' (or maybe ThisWorkbook)
Application.ScreenUpdating = False
Dim i As Long, j As Long
For i = 1 To wb.Worksheets.Count - 1
For j = i + 1 To wb.Worksheets.Count
' ==> The following line needs to be replaced!
If wb.Worksheets(j).Name < wb.Worksheets(i).Name Then
wb.Worksheets(j).Move before:=wb.Worksheets(i)
End If
Next j
Next i
' Application.ScreenUpdating = True
End Sub
The only logic you need to change now is the If-statement. Instead of comparing the names of the sheets, you need to find a custom logic that compares the names of the two sheets.
Your logic is basically: If the name is Initial, sort it to the top, if it is Version, sort it to the end and for all the others, sort them by the date the name is representing.
I created a small function that calculates a number from the name. The Initial sheets gets 0, the Version gets a arbitrary high number, a worksheet with a date in the name gets the date value (a date is basically a double value in VBA) by converting the name into the date. If the name cannot be converted to a date, the value will be so that the sheet will be sorted to the end (but before the version sheet).
Function getSortNumber(ws As Worksheet) As Double
Const MaxNumber = 100000
If ws.Name = "Initial" Then
' Sort Initial to the beginning
getSortNumber = 0
ElseIf ws.Name = "Version" Then
' Sort Version to the end
getSortNumber = MaxNumber + ws.Parent.Sheets.Count
Else
' Create real date fom name
Dim d As Date, tokens() As String
tokens = Split(ws.Name, "-")
On Error Resume Next
d = DateSerial(Val(tokens(2)), Val(tokens(1)), Val(tokens(0)))
On Error GoTo 0
If d = 0 Then
' Failed to convert to date, sort to end
getSortNumber = MaxNumber + ws.Index
Else
' Sort according to the date value
getSortNumber = CDbl(d)
End If
End If
End Function
You can adapt the function easily if your needs changed (eg date format, or you can have extra text with the date, or you want to sort the version sheet to the beginning, or you have additional sheets with different names...). The sort function itself will not change at all, only the comparison logic.
Now all you have to do is change the line in the sort routine:
If wb.Worksheets(j).Name < wb.Worksheets(i).Name Then
to
If getSortNumber(wb.Worksheets(j)) < getSortNumber(wb.Worksheets(i)) Then
The general approach of converting the sheet names (that, hopefully, look like dates) to actual date serial numbers, and sorting those has been answered. But there is a a bit more to it than other answers show.
If your sheet names are user entered, you should handle a bit of variability
No need to reinvent Date Conversion, use whats already in Excel/VBA. But you need to define what year a 2 digit number represents, specifically which century it's in.
Note: How DateSerial interprets 2 digit dates is a bit complex. Refer to the docs for details
Decide what you want to do with sheets whose names cannot be converted to valid dates. Options include
Clean them up. eg
remove excess white space
allow for suffixes (times?)
alternate delimiters
other date forms (eg 1 Oct 2020)
etc
Aborting
Delete them
Move them to a defined location
Move them to another workbook
Prompt user for a new valid name
Generate a new valid name in the code
etc
Once the date serial numbers are created, you sort that data. Many options exist
Use the Dynamic Array function SORT, if you have it
If you don't, there are many Array Sort algorithms and implementations available for VBA
Examples 1 2
Use a data structure that supports Sorting. Example System.Collections.ArrayList 1
Dump the data onto a sheet and use Excel Sort
Once you have the sorted data, move the sheets into place. Note: another answer provide a nested For loop. This executes in order n^2 (n = number of sheets) May not matter for a smallish number of sheets, but will get much slower as the number of sheets increases. But it's easily avoided, see the code below.
Suggested methodoligy, including comments on what to change to suit your needs. Run this after the user has inserted a new sheet.
Sub SortSheets()
Dim ws As Worksheet
Dim wb As Workbook
Dim idx As Long
Dim SheetNames As Variant
Set wb = ThisWorkbook ' or specify the book you want
' Validate book contents
On Error Resume Next
Set ws = wb.Worksheets("Initial")
On Error GoTo 0
If ws Is Nothing Then
' Initial Doesn't exist. What now?
Exit Sub
End If
If ws.Index <> 1 Then
' Move it to first
ws.Move Before:=wb.Worksheets(1)
End If
On Error Resume Next
Set ws = wb.Worksheets("Version")
On Error GoTo 0
If ws Is Nothing Then
' Version Doesn't exist. What now?
Exit Sub
End If
If ws.Index <> wb.Worksheets.Count Then
' Move it to last
ws.Move After:=wb.Worksheets(wb.Worksheets.Count)
End If
' For each sheet between first and last,
' Convert Name to a dateSerial
' Handle any invalidly named sheets
ReDim SheetNames(2 To wb.Worksheets.Count - 1, 1 To 2)
For idx = 2 To wb.Worksheets.Count - 1
Set ws = wb.Worksheets(idx)
On Error Resume Next
' convert sheet name to date
SheetNames(idx, 1) = getDate(ws.Name)
On Error GoTo 0
If IsEmpty(SheetNames(idx, 1)) Then
' Invalid Sheet Name format. What Now?
' eg move it to the end (before Version)
SheetNames(idx, 1) = 3000000
' change to handle as you require, eg Delete it, Prompt user for a new name, etc
End If
SheetNames(idx, 2) = ws.Name
Next
' Sort on date using Dynamic Array Function SORT
SheetNames = Application.Sort(SheetNames)
' If SORT is not available, there are many Array Sort algorithms and implementations available
' Move sheets into position
' SheetNames is a 2D array of the DateSerial numbers and actual sheet names, sorted in the order we want them in the book
' Loop through the array lowest to highest,
' Get a reference to the sheet by name
' Move it to its required position (if it's not already there)
For idx = 1 To UBound(SheetNames, 1)
Set ws = wb.Worksheets(SheetNames(idx, 2))
If ws.Index <> idx + 1 Then
ws.Move After:=wb.Worksheets(idx)
End If
Next
End Sub
Function getDate(DateStr As String, Optional Delim As String = "-") As Long
' Cleanup sheet name
' Add or remove cleaning to suit your needs
' reduce multiple space sequences to single spaces
DateStr = Application.WorksheetFunction.Trim(DateStr)
' remove spaces aroung delimiter
DateStr = Replace$(DateStr, " " & Delim, Delim) '
DateStr = Replace$(DateStr, Delim & " ", Delim)
' replace any remaining spaces with delimiter (needed to make Val() work as desired)
DateStr = Replace$(DateStr, " ", Delim)
' Create real date from name
Dim d As Long, Segments() As String
Segments = Split(DateStr, Delim)
If UBound(Segments) < 2 Then
' not enough segments
d = 0
ElseIf UBound(Segments) > 2 Then
' too many segments. What Now?
' do nothing if it's acceptable to ignore anything after the date
Else
' Segment(0) is first part, assumed to be Day
' Segment(1) is second part, assumed to be Month
' Segment(2) is third part, assumed to be Year
' assume 2 digit dates are 2000's. Change to suit your needs
' Note: relying on DateSerial to convert 2 digit dates may give unexpected results
' as what you get depends on Excel version and local settings
If Len(Segments(2)) <= 2 Then Segments(2) = "20" & Format$(Segments(2), "00")
On Error Resume Next
d = CLng(DateSerial(CInt(Val(Segments(2))), CInt(Segments(1)), CInt(Segments(0))))
On Error GoTo 0
End If
If d = 0 Then
' Could not convert to date. Let calling routine decide what to do now
Err.Raise 1, "getDate", "Invalid Date string"
Else
' return date value
getDate = d
End If
End Function
Insert Date Worksheet
Note the following in two-digit year notation:
01/01/30 ... 01/01/1930
12/31/99 ... 12/31/1999
01/01/00 ... 01/01/2000
12/31/29 ... 12/31/2029
Some complications are present due to:
Sub Test1()
Debug.Print DateSerial(111, 22, 33) ' Result '11/02/112'
Debug.Print DateSerial(21, 2, 30) ' Result ' 03/02/2021
End Sub
The following will not sort any previously added worksheets. It will just insert the new worksheet in the right spot i.e. before the first worksheet with a greater date than the date supplied, or before the last worksheet (if no greater date).
Option Explicit
Sub InsertDateWorksheet()
' Needs 'RefWorksheet', 'InputDateText', 'GetTwoDigitYearDate' and 'IsLeapYear'.
Const ProcName As String = "InsertDateWorksheet"
Const First As String = "Initial"
Const Last As String = "Version"
Const Delimiter As String = "-"
Dim wb As Workbook: Set wb = ThisWorkbook
' First Worksheet
Dim fws As Worksheet: Set fws = RefWorksheet(wb, First, True)
If fws Is Nothing Then Exit Sub
If Not fws Is wb.Sheets(1) Then
fws.Move Before:=wb.Sheets(1)
End If
' Last Worksheet
Dim lws As Worksheet: Set lws = RefWorksheet(wb, Last, True)
If lws Is Nothing Then Exit Sub
Dim shCount As Long: shCount = wb.Sheets.Count
If Not lws Is wb.Sheets(shCount) Then
lws.Move After:=wb.Sheets(shCount)
End If
Dim NewDate As Date: NewDate = InputDateText(True)
If NewDate = 0 Then Exit Sub
Dim NewDateString As String: NewDateString = CStr(Day(NewDate)) _
& Delimiter & CStr(Month(NewDate)) & Delimiter _
& Right(CStr(Year(NewDate)), 2)
Dim nws As Worksheet: Set nws = RefWorksheet(wb, NewDateString)
If Not nws Is Nothing Then
MsgBox "The worksheet '" & NewDateString & "' already exists.", _
vbCritical, ProcName
Exit Sub
End If
Dim ws As Worksheet
Dim wsDate As Date
For Each ws In wb.Worksheets
Select Case ws.Name
Case First
Case Last
Exit For
Case Else
wsDate = GetTwoDigitYearDate(ws.Name, Delimiter)
If NewDate < wsDate Then
Exit For
End If
End Select
Next ws
Worksheets.Add(Before:=ws).Name = NewDateString
MsgBox "Worksheet '" & NewDateString & "' added.", vbInformation, ProcName
End Sub
Function RefWorksheet( _
ByVal wb As Workbook, _
ByVal WorksheetName As String, _
Optional ByVal DoWriteMessage As Boolean = False) _
As Worksheet
Const ProcName As String = "RefWorksheet"
On Error Resume Next
Set RefWorksheet = wb.Worksheets(WorksheetName)
On Error GoTo 0
If DoWriteMessage Then
If RefWorksheet Is Nothing Then
MsgBox "Worksheet '" & WorksheetName & "' not found.", _
vbCritical, ProcName
Exit Function
End If
End If
End Function
Function InputDateText( _
Optional ByVal DoWriteMessage As Boolean = False) _
As Date
' Needs 'GetTwoDigitYearDate' and 'IsLeapYear'.
Const ProcName As String = "InputDateText"
Const InputFormat As String = "d-m-yy"
Const nTitle As String = "Input Date Text"
Dim nPrompt As String
nPrompt = "Please enter a date in '" & InputFormat & "' format..."
Dim nDefault As String: nDefault = Format(Date, InputFormat)
Dim NewDateString As Variant: NewDateString = Application.InputBox( _
nPrompt, nTitle, nDefault, , , , , 2)
If NewDateString = False Then
MsgBox "You canceled.", vbExclamation, ProcName
Exit Function
End If
InputDateText = GetTwoDigitYearDate(NewDateString, "-")
If DoWriteMessage Then
If InputDateText = 0 Then
MsgBox "The string '" & NewDateString & "' is not valid.", _
vbCritical, ProcName
End If
End If
End Function
Function GetTwoDigitYearDate( _
ByVal DateString As String, _
Optional ByVal Delimiter As String = "-") _
As Date
' Needs 'IsLeapYear'.
On Error GoTo ClearError
Dim ArrDate() As String: ArrDate = Split(DateString, Delimiter)
Dim nYear As Long: nYear = CLng(ArrDate(2))
Select Case nYear
Case Is < 0, Is > 99
Exit Function
Case Else
nYear = IIf(nYear > 29, nYear + 1900, nYear + 2000)
End Select
Dim nMonth As Long: nMonth = CLng(ArrDate(1))
Select Case nMonth
Case Is < 1, Is > 12
Exit Function
End Select
Dim nDay As Long: nDay = CLng(ArrDate(0))
Select Case nDay
Case Is < 1, Is > 31
Exit Function
End Select
Select Case nMonth
Case 4, 6, 9, 11
If nDay = 31 Then Exit Function
Case 2
If nDay > 29 Then Exit Function
If nDay = 29 Then
If Not IsLeapYear(nYear) Then Exit Function
End If
End Select
GetTwoDigitYearDate = DateSerial(nYear, nMonth, nDay)
ProcExit:
Exit Function
ClearError:
Resume ProcExit
End Function
Function IsLeapYear( _
TestYear As Long) _
As Boolean
If TestYear Mod 4 = 0 Then
If TestYear Mod 100 = 0 Then
If TestYear Mod 400 = 0 Then
' Accounting for e.g. years 2000, 2400, 2800...8800, 9200, 9600.
IsLeapYear = True
'Else
' Accounting for e.g. years 2100, 2200, 2300...9700, 9800, 9900.
'isLeapYear = False
End If
Else
' Accounting for e.g. years 1904, 1908, 1912...1988, 1992, 1996.
IsLeapYear = True
End If
'Else
' Accounting for e.g. years 1901, 1902, 1903...1997, 1998, 1999.
'isLeapYear = False
End If
End Function

Table refresh vba excel Call procedure from another procedure Error Code 1004

I have a call procedure to clear contents of tables across multiple worksheets.
This procedure is invoked only from the 2nd sheet of the workbook. When I invoke this, I am getting Error 1004 "Application-defined or Object-defined error".
Below is the parent code base invoking the sub procedure:
Sub ValidateData_BDV1()
On Error Resume Next
Err.Clear
'''''Define Variables'''''''''
Dim mySheet As Worksheet
Dim mySheetName As String
Dim bdvName As Variant
Dim sqlQuery As String
Dim connectStr As String
Dim wsMatch As Worksheet
Dim myWorkbook As Workbook: Set myWorkbook = ThisWorkbook
'''''''''Set Variables''''''''
cancelEvent = False
Set mySheet = ActiveSheet 'Sets mySheet variable as current active sheet
mySheetName = mySheet.Name
driverName = mySheet.Range("B1").Value2 'Get the value of the TDV driver
' MsgBox driver
dataSourceName = mySheet.Range("B3").Value2 'Get the data source name for the published TDV database
' MsgBox dataSourceName
schemaName = mySheet.Range("B5").Value2 'Get the schema name of the published tdv view
bdvName = mySheet.Range("B6").Value2 'Get the name of the published BDV
''''''''''Refresh data across sheets'''''''''''''
Application.ScreenUpdating = False 'Prevent screen flickering while doing the refresh
'''''''''''''''''''''''''''''''''''''''
''''''''''''Call sub procedure'''''''''
Call ClearTableContents
''''''''''''''''''''''''''''''''''''
mySheet.Activate
Application.ScreenUpdating = True 'Prevent screen flickering while doing the refresh
''''''''Show User id and Password box'''''''''
If Len(Uid) < 1 Or Len(Password) < 1 Then
UserForm1.Show
End If
If (cancelEvent = True) Then
Exit Sub
End If
............
............perform some task with error handling
Below is the code base of the called Sub
Sub ClearTableContents()
Dim wrksht As Worksheet
Dim objListObj As ListObjects
Dim tableName As String
Dim ActiveTable As ListObject
Dim rowCount As Integer
Dim colCount As Integer
Dim i As Integer
Dim j As Integer
'''''Iterate through the Bdv1, bdv2 and Match sheets. Set default table sizes for each
sheet'''''''''
For j = 2 To 4
If (j = 2) Or (j = 3) Then
rowCount = 5
colCount = 6
ElseIf (j = 4) Then
rowCount = 5
colCount = 9
End If
Application.ScreenUpdating = False 'Prevent screen flickering while doing the refresh
Set wrksht = ActiveWorkbook.Worksheets(j)
Set objListObj = wrksht.ListObjects 'Get list of tables objects from the current sheet
'''''''Iterate through the tables in the active worksheet''''''''''''''
For i = 1 To objListObj.Count
tableName = objListObj(i).Name
Set ActiveTable = wrksht.ListObjects(tableName)
On Error Resume Next
''''''For each table clear the contents and resize the table to default settings''''''''''''
With wrksht.ListObjects(i)
.DataBodyRange.Rows.Clear
.Range.Rows(rowCount & ":" & .Range.Rows.Count).Delete
.HeaderRowRange.Rows.ClearContents
.HeaderRowRange.Rows.Clear
.Range.Columns(colCount & ":" & .Range.Columns.Count).Delete
.Resize .Range.Resize(rowCount, colCount)
End With
wrksht.Columns("A:Z").AutoFit
Next i
Next j
ThisWorkbook.Worksheets(2).Activate '''set the active sheet to the sheet number 2
Application.ScreenUpdating = True 'Prevent screen flickering while doing the refresh
Exit Sub
'Error Handling
NoTableSelected:
MsgBox "There is no Table currently selected!", vbCritical
End Sub
Please help in resolving the issue.
If I execute as independent macro on click of the button, it works perfectly well.
I am going to post this as an "answer", since I think it may at least help, if not solve, your issue.
Clearing tables (list objects) via VBA code can be a little tricky, and I learned this hard way. I developed and have been using the below function for quite some time and it works like a charm. There are comments to explain the code in the function.
Sub clearTable(whichTable As ListObject)
With whichTable.DataBodyRange
'to trap for the bug where using 'xlCellTypeConstants' against a table with only 1 row and column will select all constants on the worksheet - can't explain more than that its a bug i noticed and so did others online
If .rows.count = 1 And .columns.count = 1 Then
If Not .Cells(1, 1).HasFormula Then .Cells(1, 1).ClearContents
Else
'my tables often have formulas that i don't want erased, but you can remove if needed
On Error Resume Next
.SpecialCells(xlCellTypeConstants).ClearContents
On Error GoTo 0
End If
'remove extra rows so table starts clean
Dim rowCount As Long
rowCount = .rows.count
If rowCount > 1 Then .rows("2:" & rowCount).Delete 'because you can't delete the first row of the table. it will always have 1 row
End With
End Sub
Call the procedure like this:
Dim lo as ListObject
For each lo in Worksheets(1).ListObjects
clearTable lo
next
Commented line to make my code work
.Range.Columns(colCount & ":" &
.Range.Columns.Count).Delete

Is there a way to reassign a Range variable to a different range?

I am very new to VBA, having started programming it yesterday. I am writing a data processing program which requires keeping track of two cells, one on each spreadsheet. The code which reproduces the errors I am experiencing is below. When I call the sub moveCell() in sub Processor(), nothing happens to DIRow and DIColumn, and the code spits out error 1004 at the line indicated. I have tried using DICell = DICell.Offset(), but it returns the same error.
How can I redefine a Range variable to be a different cell?
'<<Main Processor Code>>'
Sub Processor()
Dim PDRow As Integer
Dim PDColumn As Integer
Dim DIRow As Integer
Dim DIColumn As Integer
PDRow = 1
PDColumn = 1
DIRow = 1
DIColumn = 1
Dim PDCell As Range
Dim DICell As Range
Set PDCell = Worksheets("Processed Data").Cells(PDRow, PDColumn)
Set DICell = Worksheets("Data Input").Cells(DIRow, DIColumn)
Call moveCell(2, 0, "Data Input")
End Sub
'<<Function which moves the cell which defines the range>>'
Sub moveCell(r As Integer, c As Integer, sheet As String)
If sheet = "Processed Data" Then
PDRow = PDRow + r
PDColumn = PDColumn + c
Set PDCell = Worksheets("Data Input").Cells(PDRow, PDColumn)
ElseIf sheet = "Data Input" Then
DIRow = DIRow + r '<<<<<<This line does nothing to DIRow's value
DIColumn = DIColumn + c
Set DICell = Worksheets("Data Input").Cells(DIRow, DIColumn) '<<<<<<This line causes error 1004
End If
End Sub
As far as I can tell, you could instead use a quick Function instead. There doesn't seem to be any difference in your If statement results in the moveCell() function, except which worksheet you're using.
We can make this simpler by referring to the Range you're passing to moveCell.
Option Explicit ' forces you to declare all variables
Sub something()
Dim PDCell As Range
Set PDCell = Worksheets("Processed Data").Cells(1, 1)
Dim DICell As Range
Set DICell = Worksheets("Data Input").Cells(1, 1)
PDCell.Select ' can remove
Set PDCell = moveCell(2, 0, PDCell, PDCell.Worksheet.Name)
PDCell.Select ' can remove
Worksheets(DICell.Worksheet.Name).Activate ' can remove
DICell.Select ' can remove
Set DICell = moveCell(5, 0, DICell, DICell.Worksheet.Name)
DICell.Select ' can remove
End Sub
Function moveCell(rowsToMove As Long, colsToMove As Long, cel As Range, ws As String) As Range
Set moveCell = Worksheets(ws).Cells(cel.Row + rowsToMove, cel.Column + colsToMove)
End Function
I've included some rows you don't need (which I've marked with a comment afterwards), but that will show you how the routine works. You can step through with F8 to help see it step-by-step.
Edit: Although, you don't need a separate function at all. Just use OFFSET().
Set PDCell = ...whatever originally
Set PDCell = PDCell.Offset([rows],[cols])

getting run time 13 error in vba how to fix this

I'm actually trying to code the sumproduct VBA script but I'm getting the runtime 13 error...
VBA:
Option Explicit
Sub sample_sumpro()
Dim cal_date, nxt_date As Date
cal_date = #12/30/2016#
nxt_date = cal_date + 1
Dim name As String, ws As Sheets
name = "Kawale, Amar"
Dim dm_daily As String
With Sheets(1)
dm_daily = Application.Evaluate("SUMPRODUCT((Columns(16)=name)*Columns(4)>=cal_date)*Columns(4)<nxt_date))")
End With
MsgBox dm_daily
End Sub
In a comment to another answer, you say that you are actually trying to do a count with two criteria (or three criteria according to the question). That is better achieved with Excel's CountIfs function, which can be coded in VBA using something like:
Option Explicit
Sub sample_sumpro()
Dim cal_date As Date, nxt_date As Date
Dim name As String
Dim dm_daily As String
cal_date = #12/30/2016#
nxt_date = cal_date + 1
name = "Kawale, Amar"
With Sheets(1)
dm_daily = Application.WorksheetFunction.CountIfs(.Columns(16), name, _
.Columns(4), ">=" & CDbl(cal_date), _
.Columns(4), "<" & CDbl(nxt_date))
End With
MsgBox dm_daily
End Sub
I didn't get exactly what you're trying to do, but if (just a guess) you're trying to evaluate the SUMPRODUCT of columns 14 and 15, you might want to try this:
Sub TestEvaluate()
Dim ws As Worksheet, x As String
Set ws = Worksheets(2)
x = Evaluate("sumproduct(" & ws.Columns(14).Address & "," & ws.Columns(15).Address & ")")
MsgBox x
End Sub

How can I loop through a subset of worksheets?

I know how to loop through all the worksheets in a workbook, and how to exit once I reach an 'end-flag' worksheet:
For Each ThisWorkSheet In Worksheets
If ThisWorkSheet.Name = "FlagEnd" Then Exit For
MsgBox "This worksheet name is: " & ThisWorkSheet.Name
Next
However I cannot get the loop to begin on a 'start-flag' worksheet (or even better on the worksheet right after the start-flag worksheet. For example the flagged start/end worksheets are in the middle of a bunch of other worksheets, so beginning or end traversing is not workable.
There could be hundreds of worksheets before that 'FlagStart' sheet, so I really need to start on the right sheet.
Tried:
Set ThisWorkSheet = Sheets("FlagNew")
and
For Each Sheets("FlagNew") In Worksheets
Ideas?
Solution:
Mathias was very close, but dendarii was that tiny step closer with the custom ending index. I actually figured out my final solution on my own, but wanted to give credit. Here was my final solution:
Private Sub CommandButtonLoopThruFlaggedSheets_Click()
' determine current bounds
Dim StartIndex, EndIndex, LoopIndex As Integer
StartIndex = Sheets("FlagNew").Index + 1
EndIndex = Sheets("FlagEnd").Index - 1
For LoopIndex = StartIndex To EndIndex
MsgBox "this worksheet is: " & Sheets(LoopIndex).Name
' code here
Next LoopIndex
End Sub
If this is not a particularly changeable workbook (i.e. worksheets are not being added and deleted all the time), you could store the names of the worksheets in a range on a hidden sheet and loop through them by name.
However, it sounds like they are stored consecutively in the workbook so, building on Mathias' solution, you could use a function to return the indices of the start and end worksheets and then loop through:
Public Function GetStartIndex() As Integer
On Error Resume Next
GetStartIndex = ThisWorkbook.Worksheets("MyStartingWorksheet").Index + 1
End Function
Public Function GetEndIndex() As Integer
On Error Resume Next
GetEndIndex = ThisWorkbook.Worksheets("MyEndingWorksheet").Index - 1
End Function
Sub LoopThrough()
Dim wks As Worksheet
Dim i As Integer
Dim iStart As Integer
Dim iEnd As Integer
iStart = GetStartIndex()
iEnd = GetEndIndex()
If iStart > 0 And iEnd > 0 And iEnd > iStart Then
For i = iStart To iEnd
Set wks = ThisWorkbook.Worksheets(i)
MsgBox wks.Name
Next i
End If
End Sub
I believe that if you use "foreach" you won't have any control over the starting sheet. For that matter, I am not even sure you are guaranteed the order in which the iteration will take place.
I think what you should do is first, get the index of the sheet you are interested in (get the sheet by name, and get its index), and then iterate using a for loop, over the indexes of the sheets starting at the flag sheet index.
[Edit: I hacked through a quick example]
Sub Iterate()
Dim book As Workbook
Dim flagIndex As Integer
Dim flagSheet As Worksheet
Set book = ActiveWorkbook
Set flagSheet = book.Worksheets("Sheet3")
flagIndex = flagSheet.Index
Dim sheetIndex As Integer
Dim currentSheet As Worksheet
For sheetIndex = flagIndex To book.Worksheets.Count
Set currentSheet = book.Worksheets(sheetIndex)
Next
End Sub
How about?
For Each ThisWorkSheet In Worksheets
If ThisWorkSheet.Name = "FlagStart" Then output = true
If ThisWorkSheet.Name = "FlagEnd" Then Exit For
If output = true Then MsgBox "This worksheet name is: " & ThisWorkSheet.Name
Next
This code might not be quite right. I'm writing it in the SO editor not VBA, but you get the idea.
Do the sheets you iterate over have a common name format?
Ex)
Sheets(0).name > "Reports"
Sheets(1).name > "Start Here"
Sheets(2).name > "emp.0001"
Sheets(3).name > "emp.0002"
Sheets(4).name > "emp.0003"
Sheets(5).name > "emp.0004"
Sheets(6).name > "End Here"
If so, in your for each loop, just do a Left(ThisWorkSheet.name, 4) = "emp" to verify if it's a sheet you want to reference.
In Excel VBA 2013 if you have the worksheets you want to update between tabs "Blankfirst" and "Blanklast" this works.
Use the code below to test it brings back your tab names and then replace your manipulating code in place of MsgBox wks.Name part.
Sub Macro2()
On Error Resume Next
GetStartIndex = ThisWorkbook.Worksheets("Blankfirst").Index + 1
On Error Resume Next
GetEndIndex = ThisWorkbook.Worksheets("Blanklast").Index - 1
Dim wks As Worksheet
Dim i As Integer
Dim iStart As Integer
Dim iEnd As Integer
iStart = GetStartIndex
iEnd = GetEndIndex
If iStart > 0 And iEnd > 0 And iEnd > iStart Then
For i = iStart To iEnd
Set wks = ThisWorkbook.Worksheets(i)
MsgBox wks.Name
Next i
End If
End Sub
Public Sub ITERATE_WORKSHEETS()
On Error Resume Next
Dim x As Long
For x = 0 To 100
MsgBox Worksheets(x).Name
Next x
On Error GoTo 0
MsgBox "all done"
End Sub

Resources