How to loop through only the worksheets included in a list? - vba

I am trying to use VBA to loop through worksheets in my file but only those that are included in a list on a control worksheet, e.g.
Worksheet List
When I try to look up the worksheet name in this list, it does not recognise the worksheet name as a string.
Current code below:
I create a function to vlookup on the list:
Public Function IsInRunList(WsName As Variant, RunList As Range) As Boolean
If Application.VLookup(WsName, RunList, 1, False) = WsName Then
IsInRunList = True
End If
End Function
Then I call this function in my subroutine:
Dim Ws As Worksheet
For Each Ws In ThisWorkbook.Worksheets
If IsInRunList(Ws.Name, Range("Run_List").Columns(j)) Then
I get a mismatch error for Ws.Name here.
Any ideas?
Thanks.

Try the next approach, please:
Sub iterateBetweenSheetInList()
Dim sh As Worksheet
For Each sh In ActiveWorkbook.Worksheets
Select Case sh.Name
Case "Sheet1", "Sheet2", "Sheet4", "Sheet7"
Debug.Print sh.UsedRange.Rows.Count
'your code can do here whatever you need...
End Select
Next
End Sub
Or a version to take the sheets name from a range (in column X:X in the code example). You did not show us in which column the sheets list exists:
Sub iterateBetweenSheetInListBis()
Dim sh As Worksheet, ws As Worksheet, arrSh As Variant, El As Variant
Set sh = ActiveSheet
'adapt the next range with the lettr of your column where the sheets name exists:
arrSh = sh.Range("X2:X" & sh.Range("X" & Rows.Count).End(xlUp).row).Value
For Each El In arrSh
Set ws = Worksheets(El)
Debug.Print ws.UsedRange.Rows.Count
'do here whatever you need...
Next
End Sub

Application.VLookup returns a Range when successful and an error if not (same behavior as in Excel). An error is not a string, it's a special type that you can check with IsError.
Change your checking routine to something like:
Public Function IsInRunList(WsName As Variant, RunList As Range) As Boolean
Dim res As Variant
res = Application.VLookup(WsName, RunList, 1, False)
IsInRunList = Not IsError(res)
End Function

Related

Split Worksheets

Currently this macro splits worksheets based on a cell.
It works well, however I am putting it as a button on a different page but this selects the active page, I want it to run this macro on a specific sheet.
Sub SplitToWorksheets_step4()
'Splits the workbook into different tabs
Dim ColHead As String
Dim ColHeadCell As Range
Dim icol As Integer
Dim iRow As Long 'row index on Fan Data sheet
Dim Lrow As Integer 'row index on individual destination sheet
Dim Dsheet As Worksheet 'destination worksheet
Dim Fsheet As Worksheet 'fan data worksheet (assumed active)
Again:
'ColHead = Worksheets("Diversion Report") 'this ask the user to enter a colunm name
ColHead = InputBox("Enter Column Heading", "Identify Column", [c1].Value) 'this ask the user to enter a colunm name
If ColHead = "" Then Exit Sub
Set ColHeadCell = Rows(1).Find(ColHead, LookAt:=xlWhole)
If ColHeadCell Is Nothing Then
MsgBox "Heading not found in row 1"
GoTo Again
End If
Set Fsheet = ActiveSheet
icol = ColHeadCell.Column
'loop through values in selected column
For iRow = 2 To Fsheet.Cells(65536, icol).End(xlUp).Row
If Not SheetExists(CStr(Fsheet.Cells(iRow, icol).Value)) Then
Set Dsheet = Worksheets.Add(after:=Worksheets(Worksheets.Count))
Dsheet.Name = CStr(Fsheet.Cells(iRow, icol).Value)
Fsheet.Rows(1).Copy Destination:=Dsheet.Rows(1)
Else
Set Dsheet = Worksheets(CStr(Fsheet.Cells(iRow, icol).Value))
End If
Lrow = Dsheet.Cells(65536, icol).End(xlUp).Row
Fsheet.Rows(iRow).Copy Destination:=Dsheet.Rows(Lrow + 1)
Next iRow
End Sub
Function SheetExists(SheetId As Variant) As Boolean
' This function checks whether a sheet (can be a worksheet,
' chart sheet, dialog sheet, etc.) exists, and returns
' True if it exists, False otherwise. SheetId can be either
' a sheet name string or an integer number. For example:
' If SheetExists(3) Then Sheets(3).Delete
' deletes the third worksheet in the workbook, if it exists.
' Similarly,
' If SheetExists("Annual Budget") Then Sheets("Annual Budget").Delete
' deletes the sheet named "Annual Budget", if it exists.
Dim sh As Object
On Error GoTo NoSuch
Set sh = Sheets(SheetId)
SheetExists = True
Exit Function
NoSuch:
If Err = 9 Then SheetExists = False Else Stop
End Function
Change your Sub to:
Sub SplitToWorksheets_step4(SheetName as String)
and in the line:
Set Fsheet = ActiveSheet
to:
Set Fsheet = Worksheets(SheetName)
on a different page but this selects the active page, I want it to run
this macro on a specific sheet.
Well that is simple enough.
Set your Worksheet Object to a specific Sheet.Name - eg:
Dim Fsheet As Worksheet: Set Fsheet = Sheets("Your sheet name")
In a more practical usage, you could for example pass the sheet name as a procedure argument:
Private Sub SplitToWorksheets_step4(ByVal sheetName as String)
Dim fsheet as Worksheet: Set fsheet = Sheets(sheetName)
' ... do something
End Sub
Last but not least a practical way to apply a macro for every Worksheet:
Private Sub for_every_ws()
Dim ws as Worksheet
For Each ws In ThisWorkbook.Sheets
ws.Range("A1") = "I was here!" ' i.e.
Next ws
End Sub

Can't define workheet in VBA

Going crazy here. I use this definition of worksheet all the time. Copied every string to avoid typing errors. Still, the code below produces "Nothing" when I try to set FR worksheet. Pls help!
Sub FindReplace()
Dim FRep As Worksheet
Dim c As Range
Dim cText As TextBox
Dim i As Integer
Set FRep = ThisWorkbook.Worksheets("FindReplace")
For i = 1 To 23
cText = FRep.Cells(i, 3).Text
FRep.Cells(i, 2).NumberFormat = "#"
FRep.Cells(i, 2).Value = cText
Next i
The code as is seems correct. Make sure that "FindReplace" worksheet is in ThisWorkbook.
Also, you can try to get "FindReplace" worksheet by CodeName instead of by the name of the sheet. The advantage is that if the user changes the name of the worksheet, the CodeName will remain the same and you won't need to update your code to the new worksheet name.
Public Function GetWsFromCodeName(codeName As String, wb As Workbook) As Worksheet
Dim ws As Worksheet
For Each ws In wb.Worksheets
If ws.CodeName = codeName Then
Set GetWsFromCodeName = ws
Exit For
End If
Next ws
End Function
Add this function in your code:
Sub FindReplace()
Dim FRep As Worksheet
Set FRep = GetWsFromCodeName("YourCodeName", ThisWorkbook)

How can I create/copy a worksheet while naming it based on the value of a cell in a specific column but variable row?

Essentially I'm creating a tracking sheet which will have a cell on it that, when clicked, will create a new excel sheet in the same workbook. For testing purposes I'm currently just having it create a new sheet, but eventually I'll have a sheet that it'll copy. What I need help with is, how do I get VB to pull a cell value to use as the name of the new/copied sheet? Here's the scenario:
Each row will have a Client column (which is Column C) which I want to use for the names of the workbooks that will be created. I'm trying to have a cell (say column R in that row) that when clicked creates a new worksheet and pulls in the value of column C in that row as the worksheet's name.
So, say Row 5 has "Test Client" in C5. When R5 is clicked, I want it to create a sheet that is named "Test Client". I've seen solutions that use loops to go through the column and create a sheet for each, but that wouldn't really work for my scenario as I'd need them to be created on the fly and not always for each row.
I know how to create the sheets in vb but my issue is getting the name. Is there a way to get vba to pull the name from column C for the row in which it was activated? So if it was activated for Row 5, it pulls C5, if it was Row 10, it pulls C10 etc.
Any suggestions would be greatly appreciated, I'm currently using this to create the sheets:
Sub CreateSheet()
Dim ws As Worksheet
Set ws = ThisWorkbook.Sheets.Add(After:= _
ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count))
End Sub
and this to call:
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
If Target.Row > 5 And Target.Column = 18 And Target.Count = 1 Then Call CreateSheet
End Sub
The code below reads the value in Column C for the relevant row, and then passes it as a String to your Function:
Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Row > 5 And Target.Column = 18 And Target.Count = 1 Then
Dim ShtName As String
ShtName = Cells(Target.Row, "C").Value
Call CreateSheet(ShtName)
End If
End Sub
This is your function, I've added a String that is passed representing the worksheet name:
Public Sub CreateSheet(ws_Name As String)
Dim ws As Worksheet
Set ws = ThisWorkbook.Sheets.Add(After:= _
ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count))
ws.Name = ws_Name
End Sub
Update: As Shai Rado pointed out I was missing an error handler.
You should test to see if the worksheet exists first. This pattern will make it easier to debug and add functionality to your code.
Worksheet Module
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Dim ws As Worksheet
Dim WorksheetName As String
If Target.Row > 5 And Target.Column = 18 And Target.Count = 1 Then
WorksheetName = Cells(Target.Row, "C").Value
Set ws = getWorkSheet(WorksheetName)
If Not ws Is Nothing Then Set ws = getNewWorkSheet(WorksheetName)
End If
End Sub
Standard Module
Function getWorkSheet(WorksheetName As String, Optional WorkbookName As String) As Worksheet
If Len(WorkbookName) = 0 Then WorkbookName = ThisWorkbook.Name
With Workbooks(WorkbookName)
On Error Resume Next
Set getWorkSheet = .Worksheets(WorksheetName)
On Error GoTo 0
End With
End Function
Function getNewWorkSheet(WorksheetName As String, Optional WorkbookName As String) As Worksheet
Dim ws As Worksheet
If Len(WorkbookName) = 0 Then WorkbookName = ThisWorkbook.Name
With Workbooks(WorkbookName)
Set ws = .Worksheets.Add(After:=.Worksheets(.Worksheets.Count))
On Error Resume Next
ws.Name = WorksheetName
If Err.Number = 0 Then
Set getNewWorkSheet = ws
Else
ws.Delete
End If
On Error GoTo 0
End With
End Function

Copying, pasting and deleting codependent ranges to different sheets in VBA

I have a sheet, let's call it sheetA. I have a range of fields in that sheet (rangeA) which has formulas that determine two more ranges in the same sheet. Let's call them rangeB and rangeC. Once these are determined, I want to copy rangeB and rangeC into sheets sheetB and sheetC respectively. Once that is done, I would like to delete rangeA. A reset of sorts so that I can enter new values in that range manually and repeat the process.
I want to have a function/button that can accomplish this. I have tried the following:
Private Sub TransferPuzzleButton1_Click()
FirstOperation
GetFirstEmptyCell1 "sht As Worksheet", "row As Long"
SecondOperation
GetFirstEmptyCell1 "sht As Worksheet", "row As Long"
ClearCell
End Sub
Sub FirstOperation()
Dim sourceSht As Worksheet: Set sourceSht = ThisWorkbook.Worksheets(1)
Dim destSht As Worksheet: Set destSht = ThisWorkbook.Worksheets(2)
GetFirstEmptyCell(destSht, 1).Resize(25).Value = sourceSht.Range("A1:A27").Value
End Sub
Function GetFirstEmptyCell1(sht As Worksheet, row As Long) As Range
Set GetFirstEmptyCell = sht.Cells(1, sht.Columns.Count).End(xlToLeft)
If Not IsEmpty(GetFirstEmptyCell) Then Set GetFirstEmptyCell = GetFirstEmptyCell.Offset(, 1)
End Function
Sub SecondOperation()
Dim sourceSht As Worksheet: Set sourceSht = ThisWorkbook.Worksheets(1)
Dim destSht As Worksheet: Set destSht = ThisWorkbook.Worksheets(3)
GetFirstEmptyCell(destSht, 1).Resize(2).Value = sourceSht.Range("C1:C2").Value
End Sub
Function GetFirstEmptyCell2(sht As Worksheet, row As Long) As Range
Set GetFirstEmptyCell = sht.Cells(1, 2).End(xlToLeft) '
If Not IsEmpty(GetFirstEmptyCell) Then Set GetFirstEmptyCell = GetFirstEmptyCell.Offset(, 1)
End Function
Sub ClearCell()
Dim sourceSht As Worksheet: Set sourceSht = ThisWorkbook.Worksheets(1)
sourceSht.Range("F7:I10").Clear
sourceSht.Range("C1:C2").Clear
End Sub
It seems I'm mangling the beginning Sub calls somehow
With GetFirstEmptyCell1 "sht As Worksheet", "row As Long" you are trying to call a sub that takes arguments. The argument typing is done in the definition of the sub, not in the statement that calls the sub.
When you call the sub you need to supply the parameters that it expects, in this case a worksheet and a long.
So, get your data ready before you call the sub. Abbreviated:
Private Sub TransferPuzzleButton1_Click()
Dim mySheet As Worksheet
dim myNumber as Long
Set mySheet = ThisWorkbook.Worksheets("DemoSheet")
MyNumber = 1000
' now call the function
GetFirstEmptyCell1 mySheet, myNumber
End Sub
Function GetFirstEmptyCell1(sht As Worksheet, row As Long) As Range
Set GetFirstEmptyCell = sht.Cells(1, sht.Columns.Count).End(xlToLeft)
If Not IsEmpty(GetFirstEmptyCell) Then Set GetFirstEmptyCell = GetFirstEmptyCell.Offset(, 1)
End Function
By the way, the names you use inside the function are not consistent. GetFirstEmptyCell1 vs GetFirstEmptyCell.

VBA code to check each sheet, locate a cell containing =TODAY() function, and select that cell

I have a workbook with 12 worksheets each named JANUARY through FEBRUARY.
Only the current month's sheet (e.g., NOVEMBER) will ever contain a cell containing the function =TODAY() in mm/dd/yyyy date format.
When I open the workbook, I want to automatically activate the Sheet that contains this cell (in my instance Cell N2) and Select it. I am truly a newbie learning slowly, but knowledge is minimal and can't find what I need. This what I have so far, but it doesn't work:
Sub ChooseSheet()
Dim SearchString As Variant
SearchString = "TODAY()" 'string I am searching for
Do Until SearchString = "TODAY()"
If Application.WorksheetFunction.CountIf(Sheets("Sheet1").Columns(14), SearchString) > 0 Then
Worksheets("Sheet1").Activate
End If
Exit Do
Loop
End Sub
This works for me.
Sub searchToday()
Dim sh As Worksheet
Dim found As Range
For Each sh In ActiveWorkbook.Worksheets
Set found = sh.Cells.Find(what:="=TODAY()", LookIn:=xlFormulas)
If Not found Is Nothing Then
sh.Activate
found.Select
Exit Sub
End If
Next sh
End Sub
Sub Test()
Dim ws As Worksheet
Dim f As Range
For Each ws In ActiveWorkbook.Worksheets
Set f = ws.Cells.Find(What:="=TODAY()", LookIn:=xlFormulas, LookAt:=xlWhole)
If Not f Is Nothing Then
ws.Activate
f.Select
Exit For
End If
Next ws
End Sub