How can I combine 3 VBA subroutines into one? - vba

The first sub collects all the worksheets of the workbooks that are located in D:\Users\Cons\excel.
Then the second sub looks for the word "filename" in worksheet 2 then copies all the cells below to A2 in worksheet 3.
Finally the last sub should search for the word "apple" in e2:e100 in worksheet 3, and delete every row where "apple" is not found.
I have created 3 buttons and assigned the subs to each one of them. The first 2 runs fine, doing what I want, but when I click on the 3rd button (with 3rd sub behind), nothing happens,
only the first two buttons above are being shifted upwards, don't know why.
How can I combine all the 3 subs into one (that is actually working with a button click)? Thanks in advance!!!
Sub ConslidateWorkbooks()
Dim FolderPath As String
Dim Filename As String
Dim Sheet As Worksheet
Application.ScreenUpdating = False
FolderPath = "D:\Users\Cons\excel\"
Filename = Dir(FolderPath & "*.xls*")
Do While Filename <> ""
Workbooks.Open Filename:=FolderPath & Filename, ReadOnly:=True
For Each Sheet In ActiveWorkbook.Sheets
Sheet.Copy After:=ThisWorkbook.Sheets(1)
Next Sheet
Workbooks(Filename).Close
Filename = Dir()
Loop
Application.ScreenUpdating = True
Worksheets(1).Activate
End Sub
Sub FindInFirstRow()
Dim fCell As Range
Dim strFind As String
Dim wsSource As Worksheet
Dim wsDest As Worksheet
'What shall we look for?
strFind = "filename"
'What sheet are we getting data from/to?
Set wsSource = Worksheets(2)
Set wsDest = Worksheets(3)
Set fCell = wsSource.Range("1:1").Find(what:=strFind, lookat:=xlPart, MatchCase:=False)
If fCell Is Nothing Then
MsgBox "No match found"
Else
'Copy the cells *below* to A2 of destination sheet
Intersect(wsSource.UsedRange.Offset(1), fCell.EntireColumn).Copy wsDest.Range("a2")
End If
End Sub
Sub SaveSomeRows()
Dim N As Long, L As Long, r As Range
Dim s As String, v As String
Set r = ActiveSheet.Range("e2", ActiveSheet.Range("e100").End(xlUp))
N = r.Count
s = "apple"
For L = N To 1 Step -1
v = LCase(r(L).Value)
If InStr(1, v, s) = 0 Then
r(L).EntireRow.Delete
End If
Next L
End Sub

Sub TheOneSub()
ConslidateWorkbooks
FindInFirstRow
SaveSomeRows
End Sub
Sub ConslidateWorkbooks()
...
End Sub
Sub FindInFirstRow()
...
End Sub
Sub SaveSomeRows()
...
End Sub

Sub combine_all()
Call ConslidateWorkbooks
Call FindInFirstRow
Call SaveSomeRows
'Runs them sequentially
End Sub
Assign this to a button , this would run (call) the other codes in sequence

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

Finding a range of cells that contains specific values

I am new in VBA, so I am not familiar with all its capabilities. I have a worksheet with many "tables" in it. By tables, I do not mean actual Excel Table Object but chunks of data that are separated into "tables" via color/border formatting.
I can find which cell a specific table starts by finding the cell which contains "RefNum:". However, to avoid false detection of table, I would like to double check the next cells after it.
Essentially, what I want is not just to find "RefNum:" but to find the position of 3x1 array which contains the ff in correct order:
- RefNum:
- Database:
- ToolID:
Only then can I be sure that what I found was a real table.
I am thinking of finding "RefNum:" and doing if-else for verification, but maybe there is a more sophisticated way of doing it?
Thanks for the help.
Try this code:
Sub FindTables()
Dim cell As Range
Dim firstAddress As String
With Range(Cells(1, 1), Cells(Rows.Count, Columns.Count))
Set cell = .Find("RefNum", LookIn:=xlValues)
firstAddress = cell.Address
Do
'check cell next to "RefNum" and one after that
If LCase(cell.Offset(0, 1).Value) = "database" And LCase(cell.Offset(0, 2).Value) = "toolid" Then
'here, cell is first cell (ref num) of the table
cell.Interior.ColorIndex = 4
End If
Set cell = .FindNext(cell)
Loop While Not cell Is Nothing And cell.Address <> firstAddress
End With
End Sub
Based from Michal's code, this is the answer I came up with. It works well except for one thing. It does not detect the 1st cell address, only the 2nd and succeeding. Can anyone see where I made an error?
Option Explicit
Public Sub LogSum()
'Declare variables
Dim shtMacro As Worksheet 'Sheet where macro button is located
Dim Fname As Variant 'List of user-selected files
Dim bookLOG As Workbook 'Active logsheet file
Dim shtLOG As Worksheet 'Active worksheet from current active workbook
Dim WS_Count As Integer 'Number of worksheets in active workbook
Dim CellDB As Range 'First cell output for find "RefNum"
Dim FirstAddress As String 'Address of the first CellDB
Dim i As Integer, j As Integer 'Loop iterators
'Prompt user to get logsheet filenames
Fname = Application.GetOpenFilename("ALL files (*.*), *.*,Excel Workbook (*.xlsx), *.xlsxm,Excel 97-2003 (*.xls), *.xls", , "Open Logsheet Files", , True)
If (VarType(Fname) = vbBoolean) Then Exit Sub
DoEvents
'Iterate per workbook
For i = LBound(Fname) To UBound(Fname)
Set bookLOG = Workbooks.Open(Filename:=Fname(i), UpdateLinks:=0, _
ReadOnly:=True, IgnoreReadOnlyRecommended:=True) 'Open workbook i
WS_Count = bookLOG.Worksheets.Count 'Store max number of sheets
Debug.Print bookLOG.Name 'Print the workbook filename in log
'Iterate per worksheet in workbook i
For j = 1 To WS_Count
Debug.Print bookLOG.Worksheets(j).Name 'Print the current sheet in log
Set CellDB = bookLOG.Worksheets(j).UsedRange.Find("RefNum:", LookIn:=xlValues) 'Search for "RefNum:"
If (Not (CellDB Is Nothing)) Then
bookLOG.Worksheets(j).UsedRange.Select
Debug.Print "Something's found here."
FirstAddress = CellDB.Address 'Assign the 1st search address
Debug.Print FirstAddress
Do 'Check cell next to "RefNum:" and one after that
If CellDB.Offset(1, 0).Value = "DATABASE: " And CellDB.Offset(2, 0).Value = "Tester:" Then
Debug.Print "Yay! Got You"
Debug.Print CellDB.Address
Else
Debug.Print "Oops. False Alarm"
End If
Set CellDB = bookLOG.Worksheets(j).UsedRange.FindNext(CellDB)
Loop While CellDB.Address <> FirstAddress
Else
Debug.Print "Nothing found here."
End If
Next j
Next i
End Sub

(VBA) Looping through sheet codenames

In VBA, I know it's possible to loop through worksheets like so:
for i = 1 to 5
msgbox worksheets(i).cells(1,1)
next
which pulls the first 5 sheets (in order from left to right) in the workbook. How can I reference the sheet's codenames instead? As in the first worksheet in the workbook might be Sheet10, the second Sheet6, etc...So if I'm trying to loop using sheet#s (codenames), is that possible?
You can create your own collection of worksheets that you can index by the code-name. This function does that:
Function SheetsByCodeName() As Collection
Dim sh As Worksheet
Set SheetsByCodeName = New Collection
For Each sh In ThisWorkbook.Worksheets
SheetsByCodeName.Add sh, sh.CodeName
Next
End Function
and then you can use it for your indexing, like so:
dim sheetsByCN as Object: Set sheetsByCN = SheetsByCodeName
dim cn
For each cn in Array("Sheet10","Sheet11","Sheet22","Sheet5","Sheet1")
debug.print sheetsByCN(cn).Cells(1,1).value
Next
The is no indexer on codeName so you have to loop through the sheets yourself.
A very basic example would be something like this:
Public Sub FindSheets()
Dim i As Integer
Dim objSheet As Worksheet
For i = 1 To 5
Set objSheet = FindSheetByName("Sheet" & i)
If objSheet Is Nothing Then
MsgBox "No sheet with codename Sheet" & i
Else
MsgBox objSheet.Name & " has codename " & objSheet.CodeName
End If
Next
End Sub
Function FindSheetByName(ByVal v_strCodeName As String) As Worksheet
Dim objSheet As Worksheet
Set FindSheetByName = Nothing
For Each objSheet In ActiveWorkbook.Sheets
If objSheet.CodeName = v_strCodeName Then
Set FindSheetByName = objSheet
Exit Function
End If
Next
End Function
No, it's not possible to index sheets by their CodeName.
You can either loop all sheets and check their CodeName, or use a separate method:
Sub processSheet(ws As Worksheet)
Debug.Print ws.Cells(1)
End Sub
Sub process()
processSheet(Sheet10)
processSheet(Sheet11)
processSheet(Sheet12)
End Sub
Another alternative might be (not tested):
For Each ws In Array(Sheet10, Sheet11, Sheet12)
Debug.Print ws.Cells(1)
Next
If the sheets called Sht1, Sht2, ,, Sht5
Then
for i = 1 to 5
msgbox worksheets("Sht" & i).cells(1,1)
next

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

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