根據excel中的值將數據提取到新工作簿中

Question

我想基於特定單元格的值從一個speadsheet提取數據到另一個。

我想根據產品提取數據到新的工作簿。例如，購買HDD的所有客戶的數據應移至新的工作簿，並且所有購買顯示器的客戶的數據應移至另一工作簿。我有257種不同的產品類型，因此需要將數據發送到257個不同的工作簿。

我只是想知道是否有任何功能，通過我們可以搜索價值（產品在此senario），並將其移動到另一個工作表。

任何人都可以請幫助我嗎？

在此先感謝。

Answer 1

正如tkacprow所說，在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 

Answer 2

我不懷疑有任何開箱即用的「功能」來做到這一點。不過，我會處理這爲folows：

1. 分類產品按您的類別（以便進入一個工作簿的所有項目都是逐行）
2. 做一個簡單的VBA循環，其中：檢查該產品是否是一種新型的。如果是，那麼它應該關閉最後一個打開的產品工作簿，創建一個新的工作簿，例如使用產品的名稱，並將該行保存到該工作簿。如果不是，則將行保存到當前創建並打開的工作簿。

如果您在使用此VBA時遇到問題，我們將提供幫助。