Extract data into new workbook based on value in excel - excel

Question

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.

Answer 1

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

Answer 2

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.