Here is what I have. When moving data the VLOOKUP was causing errors. So I added code for a Function that does the lookup. It works well. Unless there are thousands of S/Ns it should not bog down calculation too much. I also added a sub that gathers all S/Ns and puts them into a dropdown in cell F3. If there are too many S/Ns for a dropdown let me know and I'll remove that functionality and then you can enter the S/N directly as before. There is also a sub that puts a dropdown with all worksheets except the main worksheet -- and excepting other worksheets specified in the new worksheet called control -- into H7. Finally, there is code to do the move after clicking a button.
There are a few important notes.
As mentioned above, I added a worksheet named Control. It includes a list of worksheets that do not have serial number data and that should be excluded when compiling the list of serial numbers. It also has the list of serial numbers that fill the dropdown for serial numbers in worksheet Main, cell F3.
Regarding the serial numbers, code always starts in cell B1 in the respective data worksheet to locate serial numbers. If that changes you'll have to modify code.
I named the cell containing the serial number dropdown to Input_Serial_Number. Code uses that name to know where to put the dropdown. Similarly, I added name Input_Worksheet_Name for the cell where the "move to" worksheet name is specified using the dropdown.
Oddly, the commands in the code that add the dropdown for serial numbers and for worksheets causes an error intermittently. I cannot figure out why. So code is set to not execute that command -- with a message -- if there IS an error. This is not totally satisfying but the code seems to work as expected 95% of the time. If there is no dropdown for serial numbers or worksheets you can still input them.
I used what is called an Event. In Excel an event is code that is triggered when a specific condition is met. In this case I used the Worksheet_Activate event for worksheet Main. The event puts the dropdown for serial numbers and for worksheets into worksheet Main each time that the worksheet Main is activated (by selecting its tab). That code is located in the code module for Main.
It seems likely that there will be issues. Please contact me if there ARE issues.
Here is the workbook.
VBA Code:
' ----------------------------------------------------------------
' Procedure Name: FindSNInSheets
' Purpose: Find the serial number or corresponding data item in worksheets.
' Procedure Kind: Function
' Procedure Access: Public
' Parameter psStockNumber (String): The serial number to locate.
' Parameter piColumn (Long): The column -- if any -- in which the corresponding data is located.
' Return Type: String
' Author: Jim
' Date: 7/29/2023
' ----------------------------------------------------------------
Function FindSNInSheets(psStockNumber As String, Optional piColumn As Long = 0) As String
Dim wsLoop As Worksheet
Dim rFoundCell As Range
Dim iOffset As Long
' Array holding names of worksheets to exclude from list of workshets to look in
' when searching for the serial number.
Dim asSheetsToExclude()
' Count of worksheets to exclude from the list of worksheets to look in
' when searching for the serial number.
Dim iWorksheetsToExcludeCount As Long
Dim bDoExcludeSheet As Boolean
Dim iWorksheetIndex
' How many worksheets are there to exclude from the list of worksheets to look in
' when searching for the serial number.
iWorksheetsToExcludeCount = 10
' Size the array holding names of worksheets to exclude from the list of worksheets
' to look in when searching for the serial number.
ReDim asSheetsToExclude(iWorksheetsToExcludeCount)
' Put names of worksheets to exclude into the array. Increase the number in variable
' iWorksheetsToExcludeCount before adding more name(s).
' Size the array holding names of worksheets to exclude from the list of worksheets
' to process when moving a serial number's data.
ReDim asSheetsToExclude(10)
' Put names of worksheets to exclude into the asSheetsToExclude array.
With Worksheets("Control").Range("WorksheetsToExclude")
asSheetsToExclude(1) = .Cells(1).Value
asSheetsToExclude(2) = .Cells(2).Value
asSheetsToExclude(3) = .Cells(3).Value
asSheetsToExclude(4) = .Cells(4).Value
asSheetsToExclude(5) = .Cells(5).Value
asSheetsToExclude(6) = .Cells(6).Value
asSheetsToExclude(7) = .Cells(7).Value
asSheetsToExclude(8) = .Cells(8).Value
asSheetsToExclude(9) = .Cells(9).Value
asSheetsToExclude(10) = .Cells(10).Value
End With
' Default return value -- if the serial number is not found.
FindSNInSheets = "?"
For Each wsLoop In ThisWorkbook.Worksheets
' Determine if the current worksheet being processed is to be excluded
' from the list of worksheets to look in when specifying the worksheet
' to transfer data for a serial number from.
bDoExcludeSheet = False
'
For iWorksheetIndex = 1 To UBound(asSheetsToExclude)
If wsLoop.Name = asSheetsToExclude(iWorksheetIndex) _
Then
bDoExcludeSheet = True
Exit For
End If
Next iWorksheetIndex
' If the worksheet wsLoop is not a worksheet to exclude then look in it for the serial number.
If Not bDoExcludeSheet _
Then
' Search for (Find) the serial number in worksheet wsLoop.
With wsLoop.UsedRange
Set rFoundCell = .Find(What:=psStockNumber, _
LookIn:=xlValues, _
LookAt:=xlWhole, _
SearchOrder:=xlByRows, _
SearchDirection:=xlNext, _
MatchCase:=True)
End With
' If the serial number was found (cell rFoundCell is Not Nothing) then
' the range object named rFoundCell points to the cell containing the
' serial number.
If Not rFoundCell Is Nothing _
Then
' If lookup column IS NOT specified (parameter piColumn = 0) then
' merely return the worksheet name where the serial number is found.
If piColumn = 0 _
Then
FindSNInSheets = wsLoop.Name
' If a lookup column IS specified (parameter piColumn <> 0) then
' return the value corresponding to the serial number (from the column
' in the worksheet where the serial number is found).
Else
'
If piColumn = rFoundCell.Column _
Then
FindSNInSheets = wsLoop.Name
Exit For
ElseIf piColumn < rFoundCell.Column _
Then
iOffset = rFoundCell.Column - piColumn
Else
iOffset = piColumn - rFoundCell.Column
End If
FindSNInSheets = rFoundCell.Offset(0, iOffset)
End If
' Exit the For Loop iterating through all worksheets.
Exit For
End If 'Not rFoundCell Is Nothing
End If 'Not bDoExcludeSheet
Next wsLoop
End Function
VBA Code:
Option Explicit
Option Base 1
' ----------------------------------------------------------------------------------
' Procedure Name: CreateSerialNumberDropDown
' Purpose: Put a dropdown with worksheet names into specified cell in worksheet Main
' Procedure Kind: Sub
' Procedure Access: Public
' Author: Jim
' Date: 7/28/2023
' -----------------------------------------------------------------------------------
Sub CreateSerialNumberDropDown()
' Worksheet object that points to the worksheet main
Dim wsMain As Worksheet
' Worksheet object used to loop through all worksheets to get
' serial numbers.
Dim wsLoop As Worksheet
' Object for the header cell for all S/N data in the respective
' worksheet (being processed).
Dim rSerialNumsHeaderCell As Range
' Object for the cell with dropdown containing the S/N data
Dim rSerialNumsDropDownCell As Range
' The current Serial Number being processed.
Dim sSerialNumber As String
' This array holds the names of all worksheets in the workskbook to be processed.
Dim avSheetNames() As Variant
' Used to keep track of how many to be processed worksheets to process.
Dim iWorksheetsToProcess As Long
' Used to keep track of how many worksheets have been processed.
Dim iWorksheetsProcessed
' Cell below which the list of serial numbers is located'
Dim rSerialNumbersAnchorCell As Range
' Used to keep track of the number of serial numbers processed in all worksheets.
Dim iSerialNumbersTotal As Long
' Used to keep track of the number of serial numbers processed for one worksheet.
Dim iSerialNumberLoopIndex As Long
With Application
.ScreenUpdating = False
.EnableEvents = False
End With
' Set worksheet object to point to the Main worksheet.
Set wsMain = Worksheets("Main")
' Cell where Serial Numbers dropdown list is to be located.
Set rSerialNumsDropDownCell = wsMain.Range("Input_Serial_Number") '<= cell in Main worksheet where dropdown
' list of serial numbers is to be placed.
' Call the sub that gets the current list of worksheets to be included in the
' search for serial numbers. Variable array parameter avSheetNames is returned
' with content that includes the worksheet names to look in for serial numbers.
Call CreateWorksheetsList(avSheetNames())
' Get the count of worksheets to process (iWorksheetsToProcess) from the upper bound
' of the array holding worksheet names. That Ubound is the count of entries in the array.
iWorksheetsToProcess = UBound(avSheetNames)
' Set up the range in the Control worksheet where the serial numbers are stored/listed.
Set rSerialNumbersAnchorCell = Worksheets("Control").Range("E3") 'Point the anchor cell to cell E3
rSerialNumbersAnchorCell.EntireColumn.Value = "" 'Clear values.
rSerialNumbersAnchorCell.Value = "Serial Numbers" 'Add header.
' Initialize the count of all serial numbers processed.
iSerialNumbersTotal = 0
' Iterate through all worksheets to process.
For iWorksheetsProcessed = 1 To iWorksheetsToProcess
' Set wsLoop object to point to the worksheet being processed in the current iteration.
Set wsLoop = ThisWorkbook.Worksheets(avSheetNames(iWorksheetsProcessed))
' Point rSerialNumsHeaderCell range object to the "header" cell in worksheet
' that is currently being processed.
Set rSerialNumsHeaderCell = wsLoop.Range("B1") '<= If the column where serial numbers are located in the
' data worksheets changes then change this accordingly.
' Initialize the count of serial numbers processed for the worksheet that is
' currently being processed.
iSerialNumberLoopIndex = 0
With rSerialNumsHeaderCell
' Iterate through the cells in the worksheet that is currently being processed
' which contain seiral numbers until the next cell is empty.
Do
' Increment count of cells processed in the worksheet being processed.
iSerialNumberLoopIndex = iSerialNumberLoopIndex + 1
' Increment count of all serial numbers being processed, in all worksheets.
iSerialNumbersTotal = iSerialNumbersTotal + 1
' Put the serial number intothe next cell in the range in the Control
' worksheet that contains hte list of all serial numbers.
rSerialNumbersAnchorCell.Offset(iSerialNumbersTotal).Value = .Offset(iSerialNumberLoopIndex).Value
Loop Until .Offset(iSerialNumberLoopIndex + 1) = ""
End With
' Process the next worksheet containing serial numbers.
Next iWorksheetsProcessed
' Add the workbook scoped range name pointing to the range containing the serial numbers list
' in the Control worksheet.
With ThisWorkbook
.Names("SerialNumbersList").Delete
.Names.Add _
Name:="SerialNumbersList", _
RefersTo:="=Control!" & rSerialNumbersAnchorCell.Offset(1).Resize(iSerialNumbersTotal).Address
End With
' Set up the dropdown list of serial numbers. It goes into cell rSerialNumsDropDownCell. The
' list is in the range named SerialNumbersList in the worksheet control.
' Oddly, this causes an error intermittently. So it is set to not execute if there is
' an error. Not totally satisfying but it seems to work 95% of the time. If there is
' no dropdown for serial numbers you can still input the serial number manually.
' NOTE: This sub is triggered each time that the Main worksheet is activated.
On Error GoTo DropDownError
With rSerialNumsDropDownCell.Validation
.Delete
.Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Operator:= _
xlBetween, Formula1:="=SerialNumbersList"
.IgnoreBlank = True
.InCellDropdown = True
.InputTitle = ""
.ErrorTitle = ""
.InputMessage = ""
.ErrorMessage = ""
.ShowInput = True
.ShowError = True
End With
On Error GoTo 0
' Sort the serial numbers for the validation dropdown.
With ThisWorkbook.Worksheets("Control")
.Activate
.Sort.SortFields.Clear
.Range("SerialNumbersList").Sort Key1:=.Range("SerialNumbersList").Cells(1), Order1:=xlAscending, Header:=xlNo
.Range("SerialNumbersList").Offset(-1).Cells(1).Activate
End With
wsMain.Activate
Cloesout:
Application.EnableEvents = True
Set wsMain = Nothing
Set wsLoop = Nothing
Set rSerialNumsDropDownCell = Nothing
Set rSerialNumsHeaderCell = Nothing
Exit Sub
DropDownError:
Dim sMsg As String
sMsg = "There was an error adding the serial numbers" _
& Chr(10) _
& "dropdown to worksheet Main. Try deactivating" _
& Chr(10) _
& "then reactivating worksheet Main."
MsgBox sMsg, vbExclamation
End Sub
VBA Code:
Option Explicit
Option Base 1
' -------------------------------------------------------------------------
' Procedure Name: Sub CreateWorksheetsList
' Purpose: Put a dropdown with worksheet names into specified cell in Main.
' Procedure Kind: Sub
' Procedure Access: Public
' Author: Jim
' Date: 7/28/2023
' -------------------------------------------------------------------------
Sub CreateWorksheetsList(Optional pavLookinSheets As Variant)
' Worksheeet object for the main worksheet.
Dim wsMain As Worksheet
' Single celled range object for cell into which the dropdown list will be placed.
Dim rDropdownCell As Range
' Worksheet object used to loop through the worksheets collection.
Dim wsLoop As Worksheet
' String variable holding list of sheets in dropdown list.
Dim sDropDownEntriesList As String
' Used to keep track of count of worksheets found.
Dim iWorksheetsCount As Long
' Array holding names of worksheets to exclude from list of workshets to look in
' when searching for the serial number.
Dim asSheetsToExclude()
' Count of worksheets to exclude from the list of worksheets to look in
' when searching for the serial number.
Dim iWorksheetsToExcludeCount As Long
' Boolean flag indicting whether a worksheet is to be excluded from the list of
' worksheets to specify when transferring the serial number's data to another worksheet.
Dim bDoExcludeSheet As Boolean
' Used to look for worksheets to exclude from list of worksheets from which to move data.
Dim iWorksheetIndex As Long
' Used when excluding worksheets from the list of worksheets that user sees
' when selecting a worksheet to transfer serial number's data to another worksheet.
Dim sWorksheetName As String
' Set worksheet object to point to the worksheet main.
Set wsMain = ThisWorkbook.Worksheets("Main")
' Set range objects to point to 1. cell for dropdown list of worksheet names
' and 2. the first ccell in the range named "Lookup_Sheets".
Set rDropdownCell = wsMain.Range("Input_Worksheet_Name") '<= change this if the location of the
' dropdown for worksheets is moved.
' Size the array holding names of worksheets to exclude from the list of worksheets
' to process when moving a serial number's data.
ReDim asSheetsToExclude(10)
' Put names of worksheets to exclude into the asSheetsToExclude array.
' Those worksheet names are located in the Control worksheet.
With Worksheets("Control").Range("WorksheetsToExclude")
asSheetsToExclude(1) = .Cells(1).Value
asSheetsToExclude(2) = .Cells(2).Value
asSheetsToExclude(3) = .Cells(3).Value
asSheetsToExclude(4) = .Cells(4).Value
asSheetsToExclude(5) = .Cells(5).Value
asSheetsToExclude(6) = .Cells(6).Value
asSheetsToExclude(7) = .Cells(7).Value
asSheetsToExclude(8) = .Cells(8).Value
asSheetsToExclude(9) = .Cells(9).Value
asSheetsToExclude(10) = .Cells(10).Value
End With
' --------------------------------------------
' Gather list of Worksheets to Include
' --------------------------------------------
For Each wsLoop In ThisWorkbook.Worksheets
' Determine if the current worksheet being processed is to be excluded
' from the list of worksheets to look in when specifying the worksheet
' to transfer data for a serial number from.
bDoExcludeSheet = False
' Iterate through all worksheet names in array asSheetsToExclude to determine
' if the worksheet currently being processed should be excluded from those from
' which worksheet names will be added to the list of worksheet.
For iWorksheetIndex = 1 To UBound(asSheetsToExclude)
If wsLoop.Name = asSheetsToExclude(iWorksheetIndex) _
Then
bDoExcludeSheet = True
Exit For
End If
Next iWorksheetIndex
' If the worksheet is not one that is to be excluded then add it to the list
' of worksheets for the dropdown.
If Not bDoExcludeSheet _
Then
If sDropDownEntriesList <> "" Then sDropDownEntriesList = sDropDownEntriesList & ","
sDropDownEntriesList = sDropDownEntriesList & wsLoop.Name
' Increment the count of worksheets added to the list.
iWorksheetsCount = iWorksheetsCount + 1
' Handle optional parameter: an array holding names of
' worksheets that contain serial number data.
' If caller passed that parameter to this sub then
' update it with the name of the worksheet currently
' being processed.
If Not IsMissing(pavLookinSheets) _
Then
ReDim Preserve pavLookinSheets(iWorksheetsCount)
pavLookinSheets(iWorksheetsCount) = wsLoop.Name
End If
End If
Next wsLoop
' --------------------------------------------
' Fill Workheets List Dropdown
' --------------------------------------------
' Put the dropdown containing worksheet names into the specified cell (rDropdownCell).
' Oddly, this causes an error intermittently. So it is set to not execute if there is
' an error. Not totally satisfying but it seems to work 95% of the time. If there is
' no dropdown for worksheets you can still input the worksheet name manually.
' NOTE: This sub is triggered each time that the Main worksheet is activated.
On Error GoTo DropDownError
With rDropdownCell.Validation
.Delete
.Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Operator:= _
xlBetween, Formula1:=sDropDownEntriesList
.IgnoreBlank = True
.InCellDropdown = True
.InputTitle = ""
.ErrorTitle = ""
.InputMessage = ""
.ErrorMessage = ""
.ShowInput = True
.ShowError = True
End With
On Error GoTo 0
Closeout:
Set wsLoop = Nothing
Set wsMain = Nothing
Set rDropdownCell = Nothing
Exit Sub
DropDownError:
Dim sMsg As String
sMsg = "There was an error adding the worksheets" _
& Chr(10) _
& "dropdown to worksheet Main. Try deactivating" _
& Chr(10) _
& "then reactivating worksheet Main."
MsgBox sMsg, vbExclamation
End Sub
VBA Code:
Option Explicit
' ------------------------------------------------------------------------------------------
' Procedure Name: MoveSerialNumberData
' Purpose: Move serial number from specified source worksheet to specified target worksheet.
' Procedure Kind: Sub
' Procedure Access: Public
' Author: Jim
' Date: 7/29/2023
' ------------------------------------------------------------------------------------------
Sub MoveSerialNumberData()
' Wortksheet object that points to the worksheet named Main.
Dim wsMain As Worksheet
' Wortksheet object that points to the worksheet to move data from.
Dim wsSource As Worksheet
' Wortksheet object that points to the worksheet into which the data is transferred.
Dim wsTarget As Worksheet
' Cell containing serial number in worksheet named Main.
Dim rSerialNumberCell As Range
' "Lookup" cell containing name of worksheet that contains the S/N to be moved.
Dim rWorksheetFromNameCell As Range
' Cell containing name of worksheet to transfer the S/N to.
Dim rWorksheetToNameCell As Range
' The cell where the serial number was found in the source worksheet.
Dim rSerialNumberFoundCell As Range
' Location (upperleftmost cell) where the data is to be pasted.
Dim rTargetCell As Range
' Row number of the data to move to the Source worksheet.
Dim iMoveFromRowNum As Integer
' Row number of the data to move to in the Target worksheet.
Dim iMoveToRowNum As Integer
' Count of rows that need to be moved up after the deletion.
Dim iMoveRowsCount As Integer
' Serial Number whose data is to be moved.
Dim sSerialNumberToMove As String
With Application
.ScreenUpdating = False
.EnableEvents = False
End With
' ------------------------------------
' Set Main Worksheet and Ranges
' ------------------------------------
Set wsMain = ThisWorkbook.Worksheets("Main")
With wsMain
' Set range object to point to the cell in worksheet Main that contains the serial number.
Set rSerialNumberCell = .Range("F3")
' Set range object to point to the cell in worksheet Main that contains the serial number.
Set rWorksheetToNameCell = .Range("H7")
Set rWorksheetFromNameCell = .Range("G3")
End With
' ------------------------------------
' Serial Number to Move
' ------------------------------------
' If the cell that should contain a serial number is empty then tell user and exit sub.
If rSerialNumberCell.Value = "" _
Then
MsgBox "You must specify a serial number.", vbExclamation
Exit Sub
End If
' Get serial number to move from the Main worksheet cell.
sSerialNumberToMove = rSerialNumberCell.Value
' ------------------------------------
' Set Source Worksheet
' ------------------------------------
' Set the source worksheet (object). That is the worksheet to transfer data FROM.
On Error Resume Next
Set wsSource = ThisWorkbook.Worksheets(rWorksheetFromNameCell.Value)
On Error GoTo 0
' If the source worksheet specified cannot be found then tell user and exit sub.
If wsSource Is Nothing _
Then
MsgBox "The worksheet named " & rWorksheetToNameCell.Value & " does not exist.", vbExclamation
Exit Sub
End If
' ------------------------------------
' Set Target Worksheet
' ------------------------------------
' Set the target worksheet (object). That is the worksheet to transfer data TO.
On Error Resume Next
Set wsTarget = ThisWorkbook.Worksheets(rWorksheetToNameCell.Value)
On Error GoTo 0
' If the target worksheet specified cannot be found then tell user and exit sub.
If wsTarget Is Nothing _
Then
MsgBox "The worksheet named " & rWorksheetToNameCell.Value & " does not exist.", vbExclamation
Exit Sub
End If
' ------------------------------------------------
' Source and Target Worksheets are the Same
' ------------------------------------------------
' Handle source worksheet and target worksheet are the same.
If wsSource.Name = wsTarget.Name _
Then
MsgBox "The source worksheet and the target worksheet are the same.", vbExclamation
Exit Sub
End If
' ----------------------------------------------
' Find Serial Number in Source Worksheet
' ----------------------------------------------
' Locate (Find) the cell containing the serial number to move in the source workbook.
Set rSerialNumberFoundCell = wsSource.UsedRange.Find(sSerialNumberToMove)
If rSerialNumberFoundCell Is Nothing _
Then
MsgBox "The serial number " & sSerialNumberToMove & Chr(10) _
& "in worksheet named " & wsSource.Name, vbExclamation
Exit Sub
End If
' Row number to move data from in the Source worksheet.
iMoveFromRowNum = rSerialNumberFoundCell.Row
' Get the next empty row in the target worksheet into which to put the
' transferred data.
iMoveToRowNum = wsTarget.Range("A" & Rows.Count).End(xlUp).Row + 1
' -------------------------------------------------
' Move Data from Source Worksheet to Target
' -------------------------------------------------
' Cut from the row in source worksheet and paste into the target worksheet
' next available row.
With rSerialNumberFoundCell.EntireRow
.Cut wsTarget.Rows(iMoveToRowNum & ":" & iMoveToRowNum)
End With
' Delete the row where data was transferred from in Source worksheet.
wsSource.Rows(iMoveFromRowNum & ":" & iMoveFromRowNum).Delete Shift:=xlUp
Closeout:
With wsTarget
.Activate
.Cells(1).Activate
End With
wsMain.Activate
rSerialNumberCell.Value = ""
Set wsSource = Nothing
Set wsTarget = Nothing
Set rWorksheetToNameCell = Nothing
Set rWorksheetFromNameCell = Nothing
With Application
.EnableEvents = True
.CalculateFull
.EnableEvents = True
End With
End Sub
