根据excel中的值将数据提取到新的工作簿中
我想根据特定单元格的值从一个speadsheet提取数据到另一个。
我想提取数据到基于产品的新工作簿。 例如，购买HDD的所有客户的数据应该被移动到新的工作簿，并且所有购买了显示器的顾客的数据应该被移动到另一个工作簿。 我有257种不同的产品types，所以需要将数据发送到257个不同的工作簿。
我只是想知道是否有什么function在Excel中，我们可以通过它来search价值（产品在这个senario），并将其移动到另一个工作表。
任何人都可以请帮我这个？
提前致谢。
正如tkacprow所说，在Excel中没有“开箱即用”的工具。 你最好需要一个VBAmacros来做到这一点。
我刚刚上传到我的网站的一个示例工具/工作簿，其中内置了所需的VBAmacros。 随意利用和改变这个来满足你的需求http://tomwinslow.co.uk/handy-excel-tools/ 。
让我知道，如果这不是你正在寻找的，我可以尝试修改它。
希望这可以帮助。
下面是代码，你会喜欢它，而不是从我的网站下载。
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 我不怀疑有任何开箱“function”来做到这一点。 不过，我会这样做，作为folows：
- 按类别对产品进行sorting（以便进入单个工作簿的所有项目都是逐行的）
- 做一个简单的VBA循环：检查产品是否是新的types。 如果是，则应closures上一个打开的产品工作簿，例如使用产品的名称创build一个新的工作簿，并将该行保存到该工作簿。 如果不是，则将行保存到当前创build并打开的工作簿。
如果你有这个VBA发布的问题，我们将提供帮助。