Currently I have a macro function using vba in excel that takes a row of data when you input it with a specific number. For example, I search 0.55 it will then search through "sheet 2" and paste the entire row that has 0.55 in "sheet 1".
What I would like is for it not to search an individual number, but a set of numbers found in sheet and then paste the corresponding data (full row) from sheet 2 next the data is sheet one.
Visual:
Sheet 1 sheet 1
Highlighted numbers are the ones I want found from sheet 2 (and only those)
The result would look like this:
Desired result
Where the data on the right is from sheet 2.
Current code:
Sub myFind()
'Standard module code, like: Module1.
'Find my data and list found rows in report!
Dim rngData As Object
Dim strDataShtNm$, strReportShtNm$, strMySearch$, strMyCell$
Dim lngLstDatCol&, lngLstDatRow&, lngReportLstRow&, lngMyFoundCnt&
On Error GoTo myEnd
'*******************************************************************************
strDataShtNm = "Sheet2" 'This is the name of the sheet that has the data!
strReportShtNm = "Sheet1" 'This is the name of the report to sheet!
'*******************************************************************************
Sheets(strReportShtNm).Select
Application.ScreenUpdating = False
'Define data sheet's data range!
Sheets(strDataShtNm).Select
With ActiveSheet.UsedRange
lngLstDatRow = .Rows.Count + .Row - 1
lngLstDatCol = .Columns.Count + .Column - 1
End With
Set rngData = ActiveSheet.Range(Cells(1, 1), Cells(lngLstDatRow, lngLstDatCol))
'Get the string to search for!
strMySearch = InputBox("Enter what to search for, below:" & vbLf & vbLf & _
"Note: The search is case sensitive!", _
Space(3) & "Find All", _
"")
'Do the search!
For Each Cell In rngData
strMyCell = Cell.Value
'If found then list entire row!
If strMyCell = strMySearch Then
lngMyFoundCnt = lngMyFoundCnt + 1
ActiveSheet.Rows(Cell.Row & ":" & Cell.Row).Copy
With Sheets(strReportShtNm)
'Paste found data's row!
lngReportLstRow = .UsedRange.Rows.Count + .UsedRange.Row
ActiveSheet.Paste Destination:=.Range("A" & lngReportLstRow).EntireRow
End With
End If
Next Cell
myEnd:
'Do clean-up!
Application.ScreenUpdating = True
Application.CutCopyMode = False
Sheets(strReportShtNm).Select
'If not found then notify!
If lngMyFoundCnt = 0 Then
MsgBox """" & strMySearch & """" & Space(3) & "Was not found!", _
vbCritical + vbOKOnly, _
Space(3) & "Not Found!"
End If
End Sub
Thank you so much in advance
Related
I have the below code for one of my financial reports and I'm struggling with updating the code to make it more automated. The code creates a string of the column headers stored in multiple sheets. Each column header is a new tab in wb2. I can't figure out how to get formulas copied into a new address range. it needs to copy the values to that Sheet in wb2 and then move on to the next.
So the code needs to:
1/put the column headers to a string/array [Works]
2/look through string/array and find that column in wb1 [Works]
3/then copy specific ranges to wb2 (name is based of column header/string value) [Works]
4/copy formula into column G, based on row similar to what it does for column A addresses - for example if the range is G9, it needs to copy the formula H9-A9, etc
5/go to next value
Any help or direction would be appreciated.
Sub Prepare_CYTD_Report()
Dim addresses() As String
Dim addresses2() As String
Dim wb1 As Workbook, wb2 As Workbook
Dim my_Filename
'Declare variables for MHP60
Dim i As Long, lastcol As Long
Dim tabNames As Range, cell As Range, tabName As String
'Declare variables for MHP61
Dim i2 As Long, lastCol2 As Long
Dim tabNames2 As Range, cell2 As Range, tabName2 As String
'Declare variables for MHP62
Dim i3 As Long, lastCol3 As Long
Dim tabNames3 As Range, cell3 As Range, tabName3 As String
addresses = Strings.Split("A9,A12:A26,A32:A38,A42:A58,A62:A70,A73:A76,A83:A90", ",") 'Trial Balance string values
addresses2 = Strings.Split("G9,G12:G26,G32:G38,G42:G58,G62:G70,G73:G76,G83:G90", ",") 'Prior Month string values
Set wb1 = ActiveWorkbook 'Trial Balance to Financial Statements Workbook
'*****************************Load Column Header Strings
lastcol = wb1.Sheets("MHP60").Cells(5, Columns.Count).End(xlToLeft).Column
On Error Resume Next
Set tabNames = wb1.Sheets("MHP60").Cells(4, 3).Resize(1, lastcol - 2).SpecialCells(xlCellTypeConstants)
'actual non-formula text values on row 4 from column C up to column lastCol'
On Error GoTo 0
If Err.Number <> 0 Then
MsgBox "No headers were found on row 4 of MHP60", vbCritical
Exit Sub
End If
lastCol2 = wb1.Sheets("MHP61").Cells(5, Columns.Count).End(xlToLeft).Column
On Error Resume Next
Set tabNames2 = wb1.Sheets("MHP61").Cells(4, 3).Resize(1, lastcol - 2).SpecialCells(xlCellTypeConstants)
'actual non-formula text values on row 4 from column C up to column lastCol'
On Error GoTo 0
If Err.Number <> 0 Then
MsgBox "No headers were found on row 4 of MHP61", vbCritical
Exit Sub
End If
lastCol3 = wb1.Sheets("MHP62").Cells(5, Columns.Count).End(xlToLeft).Column
On Error Resume Next
Set tabNames3 = wb1.Sheets("MHP62").Cells(4, 3).Resize(1, lastcol - 2).SpecialCells(xlCellTypeConstants)
'actual non-formula text values on row 4 from column C up to column lastCol'
On Error GoTo 0
If Err.Number <> 0 Then
MsgBox "No headers were found on row 4 of MHP62", vbCritical
Exit Sub
End If
'*****************************Open CYTD/FYTD files
my_Filename = Application.GetOpenFilename(fileFilter:="Excel Files,*.xl*;*.xm*", Title:="Select File to create Reports")
If my_Filename = False Then
Exit Sub
End If
Application.ScreenUpdating = False
Set wb2 = Workbooks.Open(my_Filename)
'*****************************Copy values to Financial statements workbook
For Each cell In tabNames
tabName = Strings.Trim(cell.Value2)
'dedicated variable in case of requirement for further parsing (space/comma elimination?)'
If CStr(wb1.Sheets("MHP60").Evaluate("ISREF('[" & wb2.Name & "]" & tabName & "'!$A$1)")) = "True" Then
'If wb2 has a tab named for the value in tabName
For i = 0 To UBound(addresses)
wb2.Sheets(tabName).Range(addresses(i)).Value2 = wb1.Sheets("MHP60").Range(addresses(i)).Offset(0, cell.Column - 1).Value2
'wb2.Sheets(tabName).Range(addresses2(i)).Value2 =
'Debug.Print "data for " & wb2.Sheets(tabName).Range(addresses(i)).Address(, , , True) & " copied from " & wb1.Sheets("MHP60").Range(addresses(i)).Offset(0, cell.Column - 1).Address(, , , True)
Next i
Else
Debug.Print "A tab " & tabName & " was not found in " & wb2.Name
End If
Next cell
For Each cell In tabNames2
tabName2 = Strings.Trim(cell.Value2)
'dedicated variable in case of requirement for further parsing (space/comma elimination?)'
If CStr(wb1.Sheets("MHP61").Evaluate("ISREF('[" & wb2.Name & "]" & tabName2 & "'!$A$1)")) = "True" Then
'If wb2 has a tab named for the value in tabName
For i = 0 To UBound(addresses)
wb2.Sheets(tabName2).Range(addresses(i)).Value2 = wb1.Sheets("MHP61").Range(addresses(i)).Offset(0, cell.Column - 1).Value2
'Debug.Print "data for " & wb2.Sheets(tabName2).Range(addresses(i)).Address(, , , True) & " copied from " & wb1.Sheets("MHP61").Range(addresses(i)).Offset(0, cell.Column - 1).Address(, , , True)
Next i
Else
Debug.Print "A tab " & tabName2 & " was not found in " & wb2.Name
End If
Next cell
For Each cell In tabNames3
tabName3 = Strings.Trim(cell.Value2)
'dedicated variable in case of requirement for further parsing (space/comma elimination?)'
If CStr(wb1.Sheets("MHP62").Evaluate("ISREF('[" & wb2.Name & "]" & tabName3 & "'!$A$1)")) = "True" Then
'If wb2 has a tab named for the value in tabName
For i = 0 To UBound(addresses)
wb2.Sheets(tabName3).Range(addresses(i)).Value2 = wb1.Sheets("MHP62").Range(addresses(i)).Offset(0, cell.Column - 1).Value2
'Debug.Print "data for " & wb2.Sheets(tabName2).Range(addresses(i)).Address(, , , True) & " copied from " & wb1.Sheets("MHP62").Range(addresses(i)).Offset(0, cell.Column - 1).Address(, , , True)
Next i
Else
Debug.Print "A tab " & tabName3 & " was not found in " & wb2.Name
End If
Next cell
Application.ScreenUpdating = True
End Sub
Sub Prepare_CYTD_Report()
Dim addresses() As String
Dim wb1 As Workbook, wb2 As Workbook
Dim i As Long, lastCol As Long, my_FileName
Dim tabNames As Range, cell As Range, tabName As String
addresses = Strings.Split("A12:A26,A32:A38,A42:A58,A62:A70,A73:A76,A83:A90", ",")
Set wb1 = ActiveWorkbook 'Trial Balance to Financial Statements
lastCol = wb1.Sheets("MHP60").Cells(5, Columns.Count).End(xlToLeft).Column
On Error Resume Next
Set tabNames = wb1.Sheets("MHP60").Cells(4, 3).Resize(1, lastCol - 2).SpecialCells(xlCellTypeConstants)
'actual non-formula text values on row 4 from column C up to column lastCol'
On Error GoTo 0
If Err.Number <> 0 Then
MsgBox "No headers were found on row 4 of MHP60", vbCritical
Exit Sub
End If
'*****************************Open CYTD/FYTD files
my_FileName = Application.GetOpenFilename(FileFilter:="Excel Files,*.xl*;*.xm*")
If my_FileName = False Then
Exit Sub
End If
Application.ScreenUpdating = False
Set wb2 = Workbooks.Open(my_FileName)
For Each cell In tabNames
tabName = Strings.Trim(cell.Value2)
'dedicated variable in case of requirement for further parsing (space/comma elimination?)'
If CStr(wb2.Worksheets(1).Evaluate("ISREF('" & tabName & "'!$A$1)")) = "True" Then
'If wb2 has a tab named for the value in tabName
For i = 0 To UBound(addresses)
wb2.Sheets(tabName).Range(addresses(i)).Value2 = wb1.Sheets("MHP60").Range(addresses(i)).Offset(0, cell.Column - 1).Value2
'Debug.Print "data for " & wb2.Sheets(tabName).Range(addresses(i)).Address(, , , True) & " copied from " & wb1.Sheets("MHP60").Range(addresses(i)).Offset(0, cell.Column - 1).Address(, , , True)
Next i
Else
Debug.Print "A tab " & tabName & " was not found in " & wb2.Name
End If
Next cell
Application.ScreenUpdating = True
End Sub
In view of the observation made in my comment, the code presented above assumes that
the actual cell values on row 4 of MHP60 are the values 'as is' of
the actual tab names
those cell values were manually entered, i.e. not formula-driven
I am very new to Excel and macros.
I have a file with Employee data scattered over multiple worksheet in the same file. I want to search employee number in each of the sheets starting with sheet "Data Source 1" and copy all data in each row against employee ID to "Combined Data" sheet.
Next I want to search same employee ID in sheet "Data Source 2" and copy information if available to "Combined Sheet" in specified column, if information is not available search for same Employee ID in "Data Source 3" and copy data to combined sheet again in specified column only.
If it is not present then loop again start with search for new employee ID from "data source 1" sheet.
I am stuck and not able to understand how to move ahead.
Code currently being used:
Sub Search_cell()
Dim LSearchRow As Integer
Dim LCopyToRow As Integer
On Error GoTo Err_Execute
'Start search in row 3
LSearchRow = 3
'Start copying data to row 2 in Sheet Combined_data (row counter variable)
LCopyToRow = 2
Sheets("Data source 1").Select
While Len(Range("A" & CStr(LSearchRow)).Value) > 0
'If value in column A = "123", copy entire row to sheet Combined_data
If Range("A" & CStr(LSearchRow)).Value = "123" Then
'Select row in Sheet Data Source 1 to copy
Rows(CStr(LSearchRow) & ":" & CStr(LSearchRow)).Select
Selection.Copy
'Paste row into Sheet Combined_data in next row
Sheets("Combined_data").Select
Rows(CStr(LCopyToRow) & ":" & CStr(LCopyToRow)).Select
ActiveSheet.Paste
'Move counter to next row
LCopyToRow = LCopyToRow + 1
'Go back to Sheet1 to continue searching
Sheets("Data source 1").Select
End If
LSearchRow = LSearchRow + 1
Wend
'Position on cell A3
Application.CutCopyMode = False
Range("A3").Select
MsgBox "All matching data has been copied."
Exit Sub
Err_Execute:
MsgBox "An error occurred."
End Sub
Issues :
I have to manually Provide Ideantifier example "123" to be searched, I want it to take directly by going to next row in Sheet "Data Source 1"
This code copies and pastes entire row of data where Match occurs, instead I want to paste data From Sheet "Data Source 2" into column E to H in "Combined_data" sheet.
I dont understand how can I replicate the same process for sheet Data Source 2, Data Source 3.
Please try the following code.
Also rectify your sheet name from 'Date Source 1' to 'Data Source 1'
Sub CombineData()
Dim dataRng1 As Range, dataRng2 As Range, dataRng3 As Range
Dim searchRng As Range, lrow As Long, combRng As Range
Set dataRng1 = Worksheets("Data source 1").Range("A3", Worksheets("Data source 1").Range("D" & Rows.Count).End(xlUp))
Set dataRng2 = Worksheets("Data source 2").Range("A3", Worksheets("Data source 2").Range("E" & Rows.Count).End(xlUp))
Set dataRng3 = Worksheets("Data source 3").Range("A3", Worksheets("Data source 3").Range("D" & Rows.Count).End(xlUp))
lrow = Worksheets("Combined").Range("A" & Rows.Count).End(xlUp).Row
Set searchRng = Worksheets("Combined").Range("A2", Worksheets("Combined").Range("A2").End(xlDown))
Set combRng = Worksheets("Combined").Range("A3", Worksheets("Combined").Range("K" & lrow))
combRng.Cells.Clear
Dim rw As Range, destRow As Long
For Each rw In dataRng1.Rows
rw.Copy Worksheets("Combined").Range("A" & Rows.Count).End(xlUp).Offset(1, 0)
Next rw
For Each rw In dataRng2.Rows
If Not searchRng.Find(What:=rw.Cells(1, 1).Value, LookAt:=xlWhole) Is Nothing Then
destRow = searchRng.Find(What:=rw.Cells(1, 1).Value, LookAt:=xlWhole).Row
rw.Offset(0, 1).Resize(, rw.Columns.Count - 1).Copy Worksheets("Combined").Range("E" & destRow, "H" & destRow)
End If
Next rw
For Each rw In dataRng3.Rows
If Not searchRng.Find(What:=rw.Cells(1, 1).Value, LookAt:=xlWhole) Is Nothing Then
destRow = searchRng.Find(What:=rw.Cells(1, 1).Value, LookAt:=xlWhole).Row
rw.Offset(0, 1).Resize(, rw.Columns.Count - 1).Copy Worksheets("Combined").Range("I" & destRow, "K" & destRow)
End If
Next rw
End Sub
I need a macro to add text to blank cells in Column A. The macro needs to skip cells that have text. The macro needs to stop looping at the end of the data set.
I am trying to use an If Else statement, but I think I'm on the wrong track. My current, non-working code is below. Thank you so much - I'm still new to VBA
Sub ElseIfi()
For i = 2 To 100
If Worksheets("RawPayrollDump").Cells(2, 1).Value = "" Then
Worksheets("RawPayrollDump").Cells(2, 1).Value = "Administration"
Else if(not(worksheets("RawPayrollDump").cells(2,1).value="")) then 'go to next cell
End If
Next
End Sub
To find the last row of data, use the End(xlUp) function.
Try this code. It replaces all empty cells in column A with Administration.
Sub ElseIfi()
Set ws = Worksheets("RawPayrollDump")
lastrow = ws.Cells(Rows.Count, 1).End(xlUp).Row ' last data row
For i = 2 To lastrow ' all rows until last data row
If ws.Cells(i, 1).Value = "" Then ' column A, check if blank
ws.Cells(i, 1).Value = "Administration" ' set text
End If
Next
End Sub
There is no need to loop. Please try this code.
Sub FillBlanks()
Dim Rng As Range
With Worksheets("RawPayrollDump")
Set Rng = Range(.Cells(2, "A"), .Cells(.Rows.Count, "A").End(xlUp))
End With
On Error Resume Next
Set Rng = Rng.SpecialCells(xlCellTypeBlanks)
If Err Then
MsgBox "There are no blank cells" & vbCr & _
"in the specified range.", _
vbInformation, "Range " & Rng.Address(0, 0)
Else
Rng.Value = "Administration"
End If
End Sub
Replace Blanks feat. CurrentRegion
Range.CurrentRegion
Since OP asked for "... stop looping at the end of the data set. ",
I've written this CurrentRegion version.
As I understand it, the end of the data set doesn't mean that there
cannot be blank cells below the last cell containing data in column
A.
Use the 1st Sub to test the 2nd, the main Sub (replaceBlanks).
Adjust the constants including the workbook (in the 1st Sub) to fit your needs.
Criteria is declared as Variant to allow other data types not just strings.
The Code
Option Explicit
Sub testReplaceBlanks()
Const wsName As String = "RawPayrollDump"
Const FirstCellAddress As String = "A2"
Const Criteria As Variant = "Administration"
Dim wb As Workbook: Set wb = ThisWorkbook
Dim ws As Worksheet: Set ws = wb.Worksheets(wsName)
replaceBlanks ws, FirstCellAddress, Criteria
End Sub
Sub replaceBlanks(Sheet As Worksheet, _
FirstCellAddress As String, _
Criteria As Variant)
' Define column range.
Dim ColumnRange As Range
Set ColumnRange = Intersect(Sheet.Range(FirstCellAddress).CurrentRegion, _
Sheet.Columns(Sheet.Range(FirstCellAddress) _
.Column))
' To remove the possibly included cells above the first cell:
Set ColumnRange = Sheet.Range(Range(FirstCellAddress), _
ColumnRange.Cells(ColumnRange.Cells.Count))
' Note that you can also use the addresses instead of the cell range
' objects in the previous line...
'Set ColumnRange = sheet.Range(FirstCellAddress, _
ColumnRange.Cells(ColumnRange.Cells.Count) _
.Address)
' or a mixture of them.
' Write values from column range to array.
Dim Data As Variant
If ColumnRange.Cells.Count > 1 Then
Data = ColumnRange.Value
Else
ReDim Data(1 To 1, 1 To 1): Data(1, 1) = ColumnRange.Value
End If
' Modify array.
Dim i As Long, k As Long
For i = 1 To UBound(Data)
If IsEmpty(Data(i, 1)) Then Data(i, 1) = Criteria: k = k + 1
Next i
' Write modified array to column range.
' The following line is used when only the first cell is known...
'Sheet.Range(FirstCellAddress).Resize(UBound(Data)).Value = Data
' ...but since the range is known and is the same size as the array,
' the following will do:
ColumnRange.Value = Data
' Inform user.
If k > 0 Then GoSub Success Else GoSub Fail
Exit Sub
' Subroutines
Success:
MsgBox "Wrote '" & Criteria & "' to " & k & " previously " _
& "empty cell(s) in range '" & ColumnRange.Address & "'.", _
vbInformation, "Success"
Return
Fail:
MsgBox "No empty cells in range '" & ColumnRange.Address & "'.", _
vbExclamation, "Nothing Written"
Return
End Sub
Column B is Employee name and is also an individual Worksheet name.
Anticipated Outcome: A hyperlink to the individual Worksheet on each item in column B.
Issue: The code starts and stops at the top of the list and puts in a hyperlink to the last employee on the list.
Sub HyperlinkAdd()
ts= "Employee List"
lx = sheets(ts).Range("L1").value
Sheets(ts).Range("L1").Formula= "=Subtotal(3,B4:B1000)+3"
For x = 3 to lx
If Range("B" & x).value <> "" And Range("B" & x).value <> "Employees" Then
Sheets(ts).Hyperlinks.Add Anchor:Selection, Address:="", _
Subaddress:="'" & Range("B" & x) & "'!A1"
Else
End if
Next X
End Sub
Try this:
Sub add_hyperlink()
Dim target_range As Range
Dim cell As Range
Set target_range = ThisWorkbook.Sheets("Sheet1").Range("B1", Range("B1").End(xlDown))
For Each cell In target_range
ThisWorkbook.Sheets("Sheet1").Hyperlinks.Add Anchor:=cell, Address:="https://www.google.com/", SubAddress:= _
"Sheet1!A1", TextToDisplay:=cell.Value
Next cell
End Sub
How about the following, simply amend the range you want to work with, I've set it up so it works from B1 to the last populated cell on Column B:
Sub HyperlinkAdd()
Dim ws As Worksheet: Set ws = Sheets("Sheet1")
'declare and set your working worksheet, amend as required
Dim LastRow As Long
Dim rng As Range, cell As Range
LastRow = ws.Cells(ws.Rows.Count, "B").End(xlUp).Row
'get the last row with data on Column b
Set rng = ws.Range(ws.Range("B1"), ws.Range("B" & LastRow))
'set the range to work with
For Each cell In rng
If cell.Value <> "" And cell.Value <> "Employees" Then
ws.Hyperlinks.Add Anchor:=cell, Address:="", SubAddress:=cell.Value & "!A1", TextToDisplay:=cell.Value
End If
Next
End Sub
I take a different tack and make a table of contents with each sheet (with exceptions) added to the list, and hyperlinks forward and back. You'll want to change the location of the "return" link on the employee sheet to somewhere suitable.
Private Sub Make_TOC()
'TOC Table of contents Hyperlink
Dim bkEmployees As Workbook
Set bkEmployees = ActiveWorkbook
Dim shContents As Worksheet, shDetail As Worksheet
If Not WorksheetExists("Contents") Then
Set shContents = bkEmployees.Sheets.Add(before:=ActiveWorkbook.Sheets(1))
shContents.Name = "Contents"
Else
Set shContents = bkEmployees.Sheets("Contents")
shContents.Move before:=bkEmployees.Sheets(1)
End If
shContents.Activate
shContents.Range("A1").Select
shContents.Columns("A:B").NumberFormat = "#"
For locX = 2 To bkEmployees.Sheets.Count
Select Case bkEmployees.Sheets(locX).Name
'add any sheets you don't want messed with
Case "Sheet1", "Sheet2", "Contents"
'don't include the sheets above in the TOC
Case Else
shContents.Cells(locX, 1) = bkEmployees.Sheets(locX).Name
shContents.Cells(locX, 1).Select
strSubAddress = "'" & shContents.Cells(locX, 1).Value & "'!A1"
shContents.Hyperlinks.Add Anchor:=shContents.Cells(locX, 1), _
Address:="", SubAddress:="'" & bkEmployees.Sheets(locX).Name & "'" & "!A1", _
TextToDisplay:=bkEmployees.Sheets(locX).Name, ScreenTip:="Go to Detail Sheet"
'change this code to put the anchor for the return link somewhere suitable.
bkEmployees.Sheets(locX).Hyperlinks.Add Anchor:=bkEmployees.Sheets(locX).Cells(1, 1), _
Address:="", SubAddress:="'" & shContents.Name & "'" & "!A" & locX, _
TextToDisplay:="Return to TOC", ScreenTip:="Return to Table of Contents"
End Select
Next locX
shContents.Range("A1").Value = "Table Of Contents"
shContents.Range("A1").Select
shContents.Columns("A").AutoFit
End Sub
I want to extract data from one speadsheet to another based on value of a particular cell.
I want to extract data to a new workbook based on Product. For example, Data for all the customer who purchased HDD should be moved to a new workbook and data for all customer who purchased monitor should be moved to another workbook. I 257 different product types, so data needs to be send to 257 different workbooks.
I was just wondering if there is any feature in excel through which we can search for value(Product in this senario) and move it to another worksheet.
Can anyone please help me regarding this?
Thanks in advance.
As tkacprow said there is no 'out of the box' tool that wil do this for you in excel. You will ideally need a VBA macro to do this.
I have just uploaded to my website an example tool/workbook which has the required VBA macro built into it. Feel free to utilise and change this to meet you needs http://tomwinslow.co.uk/handy-excel-tools/.
Let me know if this is not exactly what you are looking for and I can try amend it.
Hope this helps.
Below is the code incase you would prefer it, rather than downloading from my site.
Sub splitMasterList()
Dim MAST As Worksheet
Set MAST = Sheets("MASTER")
Dim headerRng As Range
Dim areaSelectionCount As Long
Dim areaSelectionIsValid As Boolean
Dim areaSelectionRow As Long
Dim splitColRng As Range
Dim themeExists As Boolean
Dim themeArray() As String
ReDim Preserve themeArray(1 To 1)
Dim lastRow As Long
Dim lastSheetTabRow As Long
Dim i As Long
Dim ii As Long
Dim theme As String
Dim doesSheetExist As Boolean
Dim ws As Worksheet
Dim sheetTabRowCounter As Long
'ask the user to highlight the table header
On Error Resume Next
Set headerRng = Application.InputBox(prompt:="Please select the headings of all columns that you wish to utilise." & vbNewLine & vbNewLine & "Note: Hold the 'Ctrl' key to select multiple ranges." & vbNewLine & vbNewLine, Default:="", Type:=8)
On Error GoTo 0
If headerRng Is Nothing Then
'notify user that the process cannot continue
' MsgBox "You must select a range to undertake this process."
'exit the sub
Exit Sub
End If
'check how many areas were selected and that they all have 1 row and are all on the same line
areaSelectionCount = headerRng.Areas.Count
areaSelectionIsValid = True
areaSelectionRow = 0
'loop through all areas checking they are a vald header
i = 1
For i = 1 To areaSelectionCount
'check selection area row count
If headerRng.Areas(i).Rows.Count <> 1 Then
areaSelectionIsValid = False
End If
'check selection area row
If areaSelectionRow = 0 Then
'set areaSelectionRow
areaSelectionRow = headerRng.Areas(i).Row
Else
'test areaSelectionRow variable against the row of the area selection
If areaSelectionRow <> headerRng.Areas(i).Row Then
areaSelectionIsValid = False
End If
End If
Next i
'exit if the area selection is not valid (FALSE)
If areaSelectionIsValid = False Then
'notify user that the process cannot continue
MsgBox "You may only select headings from a single row. Please try again."
'exit the sub
Exit Sub
End If
'ask the user to select the cell heading which they would like to plit their data on
On Error Resume Next
Set splitColRng = Application.InputBox("Select a cell from anywhere in the column which you want to use to classify (split) your data.", Default:="", Type:=8)
On Error GoTo 0
If splitColRng Is Nothing Then
'notify user that the process cannot continue
MsgBox "You must select a cell to undertake this process. Please start again."
'exit the sub
Exit Sub
End If
On Error GoTo errorHandling
'turn updating off
Application.ScreenUpdating = False
'loop down the master data and
lastRow = MAST.Cells(MAST.Rows.Count, "C").End(xlUp).Row
'loop down the items in the table and build an array of all themes (based on the user split cell selection)
For i = headerRng.Row + 1 To lastRow
'if the theme is blank then insert place holder
If MAST.Cells(i, splitColRng.Column).Value = "" Then
MAST.Cells(i, splitColRng.Column).Value = "Blank / TBC"
End If
'get the theme
theme = MAST.Cells(i, splitColRng.Column).Value
'check if the theme exists in the array yet
themeExists = False
ii = 1
For ii = 1 To UBound(themeArray)
If themeArray(ii) = theme Then
'stop loop and do not add current theme to the array
themeExists = True
End If
Next ii
If themeExists = False Then
'add current theme
themeArray(UBound(themeArray)) = MAST.Cells(i, splitColRng.Column).Value
ReDim Preserve themeArray(1 To UBound(themeArray) + 1)
End If
Next i
'notify the user how many themes there are going to be
' MsgBox "The table is about to be split into " & UBound(themeArray) - 1 & " seperate sheets, each containing grouped data based on the column you selected."
'loop through the theme array and build a :
'-sheet
'-table
'-rows
'for each theme
ii = 1
For ii = 1 To UBound(themeArray) - 1
'check if sheet exists
'check if a worksheet by the name of this theme exists and create one if not
'returns TRUE if the sheet exists in the workbook
doesSheetExist = False
For Each ws In Worksheets
If Left(Replace(Replace(Replace(Replace(Replace(themeArray(ii), ",", ""), "/", ""), "\", ""), "[", ""), "]", ""), 25) = ws.Name Then
doesSheetExist = True
End If
Next ws
'create sheet if it does not exist
If doesSheetExist = False Then
'create sheet after the master sheet
Worksheets.Add After:=Worksheets(Worksheets.Count)
Set ws = ActiveSheet
'max sheet name is 31 characters and cannot contain special characters
ws.Name = Left(Replace(Replace(Replace(Replace(Replace(themeArray(ii), ",", ""), "/", ""), "\", ""), "[", ""), "]", ""), 25)
Else
'do not creat sheet but activate the existing
Sheets(Left(Replace(Replace(Replace(Replace(Replace(themeArray(ii), ",", ""), "/", ""), "\", ""), "[", ""), "]", ""), 25)).Activate
Set ws = ActiveSheet
End If
'delete any old data out of the sheet
lastSheetTabRow = ws.Cells(ws.Rows.Count, "B").End(xlUp).Row
If lastSheetTabRow < 4 Then
lastSheetTabRow = 4
End If
ws.Rows("4:" & lastSheetTabRow).Delete Shift:=xlUp
'copy table header into each sheet tab
headerRng.Copy
ws.Range("B4").Select
ws.Paste
'insert title and time stamp details into new sheet
ws.Range("B2").Value = themeArray(ii)
ws.Range("B2").Font.Size = 22
ws.Range("B2").Font.Bold = True
ws.Range("B1").Font.Size = 8
ws.Range("C1:D1").Font.Size = 8
ws.Range("C1:D1").Cells.Merge
ws.Range("B1").Value = "Timestamp : "
ws.Range("C1").Value = Now()
ws.Range("C1").HorizontalAlignment = xlLeft
ws.Range("E1").Value = "Updates must NOT be done in this worksheet!"
ws.Range("E1").Font.Color = vbRed
'loop down the items in the master table and copy them over to the correct sheet tabs based on selected theme/column
sheetTabRowCounter = 1
i = headerRng.Row + 1
For i = headerRng.Row + 1 To lastRow
'copy item from master into theme tab if matches the theme
If MAST.Cells(i, splitColRng.Column).Value = themeArray(ii) Then
'copy row
MAST.Activate
headerRng.Offset(i - headerRng.Row, 0).Copy
'paste row
ws.Activate
ws.Cells(sheetTabRowCounter + 4, 2).Select
ws.Paste
'add one to the sheet row couter
sheetTabRowCounter = sheetTabRowCounter + 1
End If
Next i
Next ii
'format new sheet
'loop through all theme sheets and size their columns to match tre master sheet
ii = 1
For ii = 1 To UBound(themeArray) - 1
Sheets(Left(Replace(Replace(Replace(Replace(Replace(themeArray(ii), ",", ""), "/", ""), "\", ""), "[", ""), "]", ""), 25)).Activate
Set ws = ActiveSheet
'loop through all of the columns on the master table and get their size
i = headerRng.Column
For i = headerRng.Column To (headerRng.Column + headerRng.Columns.Count + 1)
ws.Columns(i).ColumnWidth = MAST.Columns(i).ColumnWidth
Next i
'loop down sheet tab and autofit all row heights
ws.Rows.AutoFit
ws.Columns("A").ColumnWidth = 2
ws.Activate
'hide gridlines
ActiveWindow.DisplayGridlines = False
'freeze panes
ActiveWindow.FreezePanes = False
ws.Cells(5, 1).Select
ActiveWindow.FreezePanes = True
ws.Range("A1").Select
Next ii
'loop through all sheets and delete sheets where the timestamp exists but is older than 5 seconds
For Each ws In Worksheets
'check if cell contains a date
If IsDate(ws.Range("C1").Value) = True And ws.Range("B1").Value = "Timestamp : " Then
'delete when sheet is older than 10 seconds
If (Now() - ws.Range("C1").Value) < 10 / 86400 Then
'MsgBox "OK - " & Now() - ws.Range("C1").Value
Else
Application.DisplayAlerts = False
ws.Delete
Application.DisplayAlerts = True
End If
End If
Next ws
Application.CutCopyMode = False
'activate the master sheet
MAST.Activate
MAST.Range("A1").Select
'turn updating back on
Application.ScreenUpdating = True
'notify user process is complete
MsgBox "Done!"
Exit Sub
errorHandling:
'notify the user of error
'activate the master sheet
MAST.Activate
MAST.Range("A1").Select
'turn updating back on
Application.ScreenUpdating = True
'notify user process is complete
MsgBox "Something went wrong! Please try again." & vbNewLine & vbNewLine & "Note: This error may be being caused by an invalid heading selection range." & vbNewLine & vbNewLine & "If the problem persists contact Tom Winslow for assistance."
End Sub
I do not suspect there is any out of the box "feature" to do this. However I would approach this as folows:
Sort the product by your category (so that all items going into a single workbook are line by line)
Do a simple VBA loop which: Checks if the product is of a new type. If yes then it should close the last open product workbook, create a new workbook e.g. using the name of the product, and saves the line to that workbook. If not then save the line to the current created and open workbook.
If you have problems with this VBA post it and we will help.