我想根据特定单元格的值从一个speadsheet中提取数据。
我想将数据提取到基于Product的新工作簿。例如，购买硬盘的所有客户的数据应移至新工作簿，购买显示器的所有客户的数据应移至另一个工作簿。我有257种不同的产品类型，因此需要将数据发送到257种不同的工作簿。
我只是想知道excel中是否有任何功能可以通过它搜索值（此senario中的产品）并将其移动到另一个工作表。
有人可以帮我解决这个问题吗？
提前致谢。
答案 0 :(得分：1)
正如tkacprow所说，没有开箱即用的＆＃39;在excel中为你做这件事的工具。理想情况下，您需要一个VBA宏来执行此操作。
我刚刚在我的网站上传了一个示例工具/工作簿，其中内置了所需的VBA宏。随意使用和更改它以满足您的需求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
答案 1 :(得分：0)
我不怀疑有任何开箱即用的“功能”来做到这一点。但是我会像下面的那样接近这个：
如果您在使用此VBA时遇到问题，我们会提供帮助。