How to Search Specific Column In Each Worksheet of Excel - excel

I have an excel document with over 50 worksheets all with a similar naming convention.
As this will be so unfriendly for users to navigate to, I wrote a VBA macro which creates a worksheet called summary with the list of all the worksheets hyperlinked in a tabular form with Sheet A B and C as the Column and Sheet 1 and 2 as rows.
Now I am trying to go through each row of a specific column in Sheet 1 and Sheet 2 and look for any reference to SheetB, SheetC and SheetD and for each reference found and I want to mark that creating a matrix.
I am not sure how to achieve this. Any assistance will be much appreciated.
I have managed to search Sheet 1 and 2 for any reference to SheetB as shown below but I am not sure how to update the corresponding cell in my summary sheet.
Function findWord(word As String, wSheet As String) As Boolean
Dim LastRow As Long
Dim i As Long
LastRow = Worksheets(wSheet).Cells(Rows.Count, "D").End(xlUp).Row
For i = LastRow To 1 Step -1
If Worksheets(wSheet).Range("D" & i).Value = word Then
findWord = True
Exit Function
End If
Next i
End Function
For Each wsSheet In wbBook.Worksheets
If (wsSheet.Name <> wsActive.Name) And (Left(wsSheet.Name, 4) <> "fact") Then
For i = 2 To lastColumn
MsgBox wsSheet.Name
If findWord(columnNames(counter2), wsSheet.Name) Then
'Update summary sheet
End If
counter = counter2 + 1
Next i
End If
Next wsSheet

If the result in "Summary sheet" you are looking for is similar to this :
Then you can use something like this (read the comments inside the code for explanations)
Sub MarkReferencesToSheets()
Dim wsSummary As Worksheet 'sheet with summary table matrix
Dim wsSheetRow As Worksheet 'sheets in which we will search references to other sheets
Dim strSheetColumnName As String 'name of the reference we are looking for
Dim intSheetRow As Integer 'for loop purposes
Dim intSheetColumn As Integer 'for loop purposes
Set wsSummary = Sheets("Summary")
For intSheetRow = 2 To 3 'change to suit; headers for rows in summary sheet
Set wsSheetRow = Worksheets(wsSummary.Cells(intSheetRow, 1).Value)
For intSheetColumn = 2 To 4 'change to suit; headers for columns in summary sheet
strSheetColumnName = wsSummary.Cells(1, intSheetColumn) 'name of sheet we are looking for
If Not wsSheetRow.Columns(4).Find(strSheetColumnName) Is Nothing Then 'look only in column "D", or 4
wsSummary.Cells(intSheetRow, intSheetColumn) = "X" ' if we found it, mark it
Else
'if you want something else in the cell when reference is not found, put it here
End If
Next intSheetColumn
Next intSheetRow
End Sub

Related

How do I open another workbook with multiple sheets and find matches?

The goal is to use a reference Excel workbook as a database to find matching BoxID and then copy cells D to G in the same row. Finally pasting to another workbook that consists of a single worksheet.
I figured Xlookup would be easiest. In Excel it works but it doesn't in VBA.
Three main questions
How do I open another workbook and then reference all sheets or a specific range through all sheets in a dynamically named workbook to my current activeworkbook?
(e.g. sheets will be named freezer 23, freezer 43, fridge 190 in database.)
The rows of the sheets is variable but the columns stay the same.
Is there a way to do the above but if nothing is found to leave the cell blank?
Is there a way I could simplify this code?
On the left is the database which is going to be the external reference/where the data is coming from and on the right is the output sheet. Where I will be using Xlookup to search for the matching value. column "A" is where the search value will be and output to the next 4 cells.
Sub FreezerPulls()
Dim lastrow, j As Long
lastrow = Cells(Rows.Count, 1).End(xlUp).Row
Dim a As Integer
Dim list As Workbook
Dim frzdatabase As
Dim BoxIDlist, info, BoxIDdatabase, database, databasepath As String
databasepath = ("C:\Users\mikeo\Desktop\DataBaseStandard.xlsm")
Workbooks.Open ("C:\Users\mikeo\Desktop\DataBaseStandard.xlsm")
database = "DataBaseStandard.xlsm"
Set list = ThisWorkbook
list.Activate
Set BoxIDlist = Worksheets("Sheet1").Range("A" & Row.Count).End(xlUp).Row 'emphasized textthis doesn't work
Set BoxIDdatabase = Range("A2:A1500")
Set info = Range("D2:G1500")
a = Application.Worksheets.Count
End Sub
You could do something like this, using Match(). See comments in code
Sub FreezerPulls()
Const DB_PATH As String = "C:\Users\mikeo\Desktop\DataBaseStandard.xlsm"
Dim wbData As Workbook, ws As Worksheet, rw As Range, id, m
Set wbData = Workbooks.Open(DB_PATH, ReadOnly:=True) 'get a reference to the data workbook
'loop each row in the lookup table
For Each rw In ThisWorkbook.Sheets("Sheet1").Range("A17:F40").Rows
id = rw.Cells(1).Value 'Box ID to find
If Len(id) > 0 Then 'any value to look up?
For Each ws In wbData.Worksheets 'loop all worksheets in data workbook
m = Application.Match(id, ws.Columns("A"), 0) 'any match on this sheet ColA?
If Not IsError(m) Then 'no error = match was made on row m
rw.Cells(3).Value = ws.Name 'add freezer name
rw.Cells(4).Resize(1, 3).Value = _
ws.Cells(m, 5).Resize(1, 3).Value 'copy segment, rackID, position
Exit For 'done searching (assumes box id's are unique)
End If
Next ws
End If
Next rw
wbData.Close False
End Sub

How to copy range from multiple sheets to one sheet (one range under another) if a condition is met?

I have and excel workbook with multiple sheets and I need a range from each one to be copied into one "Main" sheet (one under another) if a condition is met.
Each sheet is different and the number of rows and cells may vary.
In all of the sheets (except the main sheet which is blank) cell B1 is a check cell that contains "yes" or is blank.
If cell B1 ="yes" the macro must migrate the range (from row 2 to the lat filled in row) into the main sheet.
The selected ranges must be copied one under another in the main sheet (so that it's like a list)
I am still a beginner in VBA and if anyone could help me a little with the code I would very much appreciate it :).
I tried to build in the code using "For Each - Next" but perhaps it would be better to make it with a Loop cicle or something else.
Sub Migrate_Sheets()
Dim wksh As Worksheet, DB_range As Range, end_row As Long, con_cell As Variant
con_cell = Range("B1")
'end_row = Range("1048576" & Rows.Count).End(xlUp).Rows
For Each wksh In Worksheets
If con_cell = "Yes" Then
Set DB_range = Range("2" & Rows.Count).End(xlDown).Rows
DB_range.Copy
wksh("Main").Activate
'row_end = Range("2" & Rows.Count).End(xlUp).Rows
Range("A1").End(xlDown).Offset(1, 0).Paste
End If
Next wksh
End Sub
There are quite a few issues here - I suggest you do some reading on VBA basics - syntax, objects, methods etc.
I've assumed you are only copying column B.
Sub Migrate_Sheets()
Dim wksh As Worksheet, DB_range As Range
For Each wksh In Worksheets
If wksh.Name <> "Main" Then 'want to exclude this sheet from the check
If wksh.Range("B1").Value = "Yes" Then 'refer to the worksheet in the loop
Set DB_range = wksh.Range("B2", wksh.Range("B" & Rows.Count).End(xlUp)) 'you need Set when assigning object variables
DB_range.Copy Worksheets("Main").Range("A" & Rows.Count).End(xlUp).Offset(1, 0) 'better to work up from the bottom and then go down 1
End If
End If
Next wksh
End Sub
See if this helps, though you might need to make some minor changes to match your data sets..
Sub Migrate_Sheets()
Dim wksh As Worksheet, mainWS As Worksheet
Dim DB_range As Range, con_cell As String
Dim lRow As Long, lCol As Long, lRowMain As Long
Set mainWS = ThisWorkbook.Worksheets("Main")
For Each wksh In Worksheets
con_cell = wksh.Range("B1").Value 'You want to use this variable within the loop
If wksh.Name <> "Main" And con_cell = "Yes" Then
lRowMain = lastRC(mainWS, "row", 1) + 1 'Add 1 to the last value to get first empty row
lRow = lastRC(wksh, "row", 1) 'Get the last row at column 1 - adjust to a different column if no values in column 1
lCol = lastRC(wksh, "col", 2) 'Get the last column at row 2 - adjust to a different row if no values in row 2
With mainWS
.Range(.Cells(lRowMain, 1), .Cells(lRowMain + lRow - 1, lCol)).Value = wksh.Range(wksh.Cells(2, 1), wksh.Cells(lRow, lCol)).Value
End With
End If
Next wksh
End Sub
Function lastRC(sht As Worksheet, RC As String, Optional RCpos As Long = 1) As Long
If RC = "row" Then
lastRC = sht.Cells(sht.Rows.Count, RCpos).End(xlUp).row
ElseIf RC = "col" Then
lastRC = sht.Cells(RCpos, sht.Columns.Count).End(xlToLeft).Column
Else
lastRC = 0
End If
End Function

Copy a row of only data then move on to the next worksheet if no values left

I don't know how to create this section of the code. This is a template code that I've used to copy specific values from a cell from each worksheet into one master worksheet that compiles that data usually into one row.
Sub distribute()
Dim sh As Worksheet
Dim destsh As Worksheet
Dim i As Integer
Set destsh = ActiveWorkbook.Worksheets.Add
destsh.Name = "Master"
i = 1
For Each sh In ActiveWorkbook.Worksheets
***destsh.Cells(i, 1).Value = sh.Range("B7:B90").SpecialCells(xlCellTypeConstants).Select***
i = i + 1
Next
ActiveWorkbook.Worksheets("Master").Cells.EntireColumn.ColumnWidth = 30
ActiveWorkbook.Worksheets("Master").Cells.EntireRow.AutoFit
ActiveWorkbook.Worksheets("Master").UsedRange.UnMerge
ActiveWorkbook.Worksheets("Master").UsedRange.WrapText = False
End Sub
I want my code to go through each worksheet in my workbook and copy the column from the range B7:B90 and stop where there are no more values within each row of each worksheet, then moves on to the next worksheet. Some worksheets have 10 cells in one row, others have 60; in this scenario my master file would show 70 cells in column A from both worksheets. The code creates a master worksheet that compiles the worksheets row B in one column.
The section I need help with has been asterisked
Your code creates the Master sheet every time which will cause the program to fail when it tries to name the sheet in the next run. Also, in your iteration through all sheets, you are reading data from Master sheet as well which might give incorrect results. I can quickly think of below code. I have used the numerical notation for rows and cells. Also since the range is constant, i looped through the range that you specified
Sub distribute()
Dim sh As Worksheet
Dim destsh As Worksheet
Dim i As Integer: i = 1
Dim sheetName As String: sheetName = ""
Set destsh = ActiveWorkbook.Worksheets.Add
'Taking sheet name as input from user
sheetName = InputBox("Enter sheetname to aggregate data")
'Checking if sheetname was entered properly
If (sheetName <> "") Then
destsh.Name = sheetName
ActiveWorkbook.Worksheets("Master").Cells.EntireColumn.ColumnWidth = 30
ActiveWorkbook.Worksheets("Master").Cells.EntireRow.AutoFit
ActiveWorkbook.Worksheets("Master").UsedRange.UnMerge
ActiveWorkbook.Worksheets("Master").UsedRange.WrapText = False
masterSheetRow = 1
For Each sh In ActiveWorkbook.Worksheets
'Making sure that the sheet is not the master sheet while getting rows
If (sh.Name <> sheetName) Then
For i = 7 To 90
If (sh.Cells(i, 2).Value <> "") Then
destsh.Cells(masterSheetRow, 1).Value = sh.Cells(i, 2).Value
masterSheetRow = masterSheetRow + 1
End If
Next
End If
Next
Else
MsgBox ("Enter valid sheetname")
End If
End Sub

Excel VBA code to copy rows to relevant named sheets not working

I have found this code on this site from a previously answered question from two years ago.
The code looks at the rows of data on a Master Sheet and copies the relevant rows based on column D (Project) to the named sheet.
If a named sheet does not exist, a comment box is added to Column D, stating that the sheet name does not exist.
The code also looks at Column A (Invoice) and uses this a a unique ID so duplicate rows are not copied to the named sheets.
I amended the code to suit my needs (sheet titles, etc) but when I run the code, the relevant row is NOT copied to the named sheet but to the next sheet to the right.
I can't work out what is wrong with the code. Hoping someone can help!!!
Column A Column B Column C Column D
Invoice Date Amount Project
I18-1234 1/10/2018 $125.00 Project 1
I18-5678 10/10/2018 $1,500.00 Project 2
I18-2468 20/10/2018 $10,000.00 Project 1
I18-7931 15/10/2018 $300.00 Project 3
I18-1010 24/10/2018 $1,000.00 Project 1
I have a main sheet named "Master Sheet". This is where all data is entered.
Currently, I have another sheet named "Project 1".
The other sheets I have are named "Sheet2" and "Sheet3". (This is just while I test the code).
Sub Test()
Dim cell As Range
Dim cmt As Comment
Dim bolFound As Boolean
Dim sheetNames() As String
Dim lngItem As Long, lngLastRow As Long
Dim sht As Worksheet, shtMaster As Worksheet
Dim MatchRow As Variant
'Set master sheet
Set shtMaster = ThisWorkbook.Worksheets("Master Data")
'Get the names for all other sheets
ReDim sheetNames(0)
For Each sht In ThisWorkbook.Worksheets
If sht.Name <> shtMaster.Name Then
sheetNames(UBound(sheetNames)) = sht.Name
ReDim Preserve sheetNames(UBound(sheetNames) + 1)
End If
Next sht
ReDim Preserve sheetNames(UBound(sheetNames) - 1)
For Each cell In shtMaster.Range("D2:D" & shtMaster.Cells(shtMaster.Rows.Count, "D").End(xlUp).Row)
bolFound = False
' instead of looping through the array of sheets >> use Application.Match
If Not IsError(Application.Match(cell.Value2, sheetNames, 0)) Then
bolFound = True
Set sht = ThisWorkbook.Worksheets(sheetNames(Application.Match(cell.Value2, sheetNames, 0)))
' now use a 2nd Match, to find matches in Unique column "A"
MatchRow = Application.Match(cell.Offset(, -3).Value, sht.Range("A:A"), 0)
If Not IsError(MatchRow) Then
shtMaster.Rows(cell.Row).EntireRow.Copy Destination:=sht.Cells(MatchRow, 1)
Else '<-- no match in sheet, add the record at the end
On Error GoTo SetFirst
lngLastRow = sht.Cells.Find("*", searchorder:=xlByRows, searchdirection:=xlPrevious).Row + 1
On Error GoTo 0
shtMaster.Rows(cell.Row).EntireRow.Copy Destination:=sht.Cells(lngLastRow, 1)
End If
End If
If bolFound = False Then
For Each cmt In shtMaster.Comments
If cmt.Parent.Address = cell.Address Then cmt.Delete
Next cmt
cell.AddComment "no sheet found for this row"
ActiveSheet.EnableCalculation = False
ActiveSheet.EnableCalculation = True
End If
Set sht = Nothing
Next
Exit Sub
SetFirst:
lngLastRow = 1
Resume Next
End Sub
change your part of the code :
' instead of looping through the array of sheets >> use Application.Match
If Not IsError(Application.Match(cell.Value2, sheetNames, 0)) Then
bolFound = True
Set sht = ThisWorkbook.Worksheets(sheetNames(Application.Match(cell.Value2, sheetNames, 0)))
to
' instead of looping through the array of sheets >> use Application.Match
If Not IsError(Application.Match(cell.Value2, sheetNames, 0)) Then
bolFound = True
Set sht = ThisWorkbook.Worksheets(cell.Value)

Need VB code that will merge two sheets into a new sheet

I am new to VB, and need some help. I have an excel 2013 workbook that has 2 sheets. Sheet1 is list of employee names (column A has 20 names), dob (column B), etc, and Sheet2 is a blank evaluation form. I need a code that will copy the entire Sheet2 (the blank form) and paste into a new Sheet3, and also pull the EmpName from row1 to a specified cell on Sheet3 (D4), same with DOB (J4), etc. I need it to repeat this process for every name on Sheet1. End goal is to have a workbook that contains 20 sheets, one for each employee, in the form of an evaluation. It would also be terrific if this code could name the tab the employee name. Is this possible? I've searched online extensively, and cannot find anything fitting.
Here is my current code. Like I said, I'm a VBA newbie. The code creates new sheets from the employee list, and copies data, but now I need it to also copy the entire sheet2 (eval form), and place the data (name cell A1 from employee list) into the form on sheet3 (new sheet) in cell D4.
Sub CreateSheetsFromEmployeeList()
Dim nameSource
Dim nameColumn
Dim nameStartRow As Long
Dim nameEndRow As Long
Dim employeeName As String
Dim newSheet As Worksheet
nameSource = "Ayre"
nameColumn = "A"
nameStartRow = 2
nameEndRow = Worksheets(nameSource).Cells(Rows.Count, nameColumn).End(xlUp).Row
Do While (nameStartRow <= nameEndRow)
employeeName = Sheets(nameSource).Cells(nameStartRow, nameColumn)
employeeName = Trim(employeeName)
If (employeeName <> vbNullString) Then
On Error Resume Next 'do not throw error
Err.Clear 'clear any existing error
Sheets(employeeName).Name = employeeName
If (Err.Number > 0) Then
Err.Clear
On Error GoTo -1
Set newSheet = Sheets.Add(After:=Sheets(Sheets.Count))
newSheet.Name = employeeName
Sheets(nameSource).Activate
LastCol = ActiveSheet.Cells(nameStartRow, Application.Columns.Count).End(xlToLeft).Column
Range(Cells(nameStartRow, 1), Cells(nameStartRow, LastCol)).Select
Selection.Copy
Sheets(employeeName).Activate 'NEW
Sheets(employeeName).Cells(1, "A").PasteSpecial
[a1].Select 'NEW
Application.CutCopyMode = False
Sheets(employeeName).Columns("A:K").AutoFit
End If
End If
nameStartRow = nameStartRow + 1
Loop
End Sub
Record a macro
When you record a macro, the macro recorder records all the steps required to complete the actions that you want your macro to perform. Iterate your action once, stop recording, then view the macro to repeat and build out your final automation macro.
This code demonstrates the basic principles you need:
Sub ExampleForAngel()
Dim names As Worksheet
Set names = Worksheets("Sheet1")
Dim eval As Worksheet
Set eval = Worksheets("Sheet2")
Dim index As Long
index = 0
Dim name As String
While (names.Range("A1").Offset(index, 0).Value <> "")
name = names.Range("A1").Offset(index, 0)
eval.Copy after:=Worksheets(Worksheets.Count)
ActiveSheet.name = name
ActiveSheet.Range("A2").Value = name
index = index + 1
Wend
End Sub

Resources