分離數據和單個的工作表將Excel的VBA

Question

我有一個大的數據具有以下形式的超過80K項設置：

 Name      Date   Value 
     1T17_4H19_3T19_3T21_2_a_2 09-Aug-11 -9.3159 
     1T17_4H19_3T19_3T21_2_a_2 10-Aug-11 -6.9662 
     1T17_4H19_3T19_3T21_2_a_2 11-Aug-11 -3.4886 
     1T17_4H19_3T19_3T21_2_a_2 12-Aug-11 -1.2357 
     1T17_4H19_3T19_3T21_2_a_2 15-Aug-11 0.1172 
     5 25_4Q27_4T30_4H34_3_3_3 19-Jun-12 -2.0805 
     5 25_4Q27_4T30_4H34_3_3_3 20-Jun-12 -1.9802 
     5 25_4Q27_4T30_4H34_3_3_3 21-Jun-12 -2.8344 
     5 25_4Q27_4T30_4Q32_a_a_a 25-Sep-07 -0.5779 
     5 25_4Q27_4T30_4Q32_a_a_a 26-Sep-07 -0.8214 
     5 25_4Q27_4T30_4Q32_a_a_a 27-Sep-07 -1.4061 

這些數據都包含在一個單一的工作表。我希望擅長根據名稱分隔數據，然後將每個時間序列放在同一工作簿中的單獨工作表中。這可能與VBA？

Answer 1

如果要錄製宏，看看會發生什麼，請按照下列步驟操作：

1. 打開宏錄製
2. 您的數據排序按名稱
3. 複製從名字
數據
4. 將其粘貼到另一個工作表（如果你需要另加片）
5. 名稱片
6. 重複下一個名稱

我也寫了一些代碼，你可以用它來開始。爲了使其工作，您需要命名數據選項卡「MasterList」。該代碼按名稱對MasterList上的行進行排序，然後爲列表中的每個唯一名稱創建一個新工作表並將相應數據複製到新工作表，重複該過程直到所有名稱都被複制到新工作表。

將此代碼添加到模塊並運行DispatchTimeSeriesToSheets過程。

Sub DispatchTimeSeriesToSheets() 
    Dim ws As Worksheet 
    Set ws = Sheets("MasterList") 
    Dim LastRow As Long 

    LastRow = Range("A" & ws.Rows.Count).End(xlUp).Row 

    ' stop processing if we don't have any data 
    If LastRow < 2 Then Exit Sub 

    Application.ScreenUpdating = False 
    SortMasterList LastRow, ws 
    CopyDataToSheets LastRow, ws 
    ws.Select 
    Application.ScreenUpdating = True 
End Sub 

Sub SortMasterList(LastRow As Long, ws As Worksheet) 
    ws.Range("A2:C" & LastRow).Sort Key1:=ws.Range("A1"), Key2:=ws.Range("B1") 
End Sub 

Sub CopyDataToSheets(LastRow As Long, src As Worksheet) 
    Dim rng As Range 
    Dim cell As Range 
    Dim Series As String 
    Dim SeriesStart As Long 
    Dim SeriesLast As Long 

    Set rng = Range("A2:A" & LastRow) 
    SeriesStart = 2 
    Series = Range("A" & SeriesStart).Value 
    For Each cell In rng 
     If cell.Value <> Series Then 
      SeriesLast = cell.Row - 1 
      CopySeriesToNewSheet src, SeriesStart, SeriesLast, Series 
      Series = cell.Value 
      SeriesStart = cell.Row 
     End If 
    Next 
    ' copy the last series 
    SeriesLast = LastRow 
    CopySeriesToNewSheet src, SeriesStart, SeriesLast, Series 

End Sub 

Sub CopySeriesToNewSheet(src As Worksheet, Start As Long, Last As Long, _ 
                 name As String) 
    Dim tgt As Worksheet 

    If (SheetExists(name)) Then 
     MsgBox "Sheet " & name & " already exists. " _ 
     & "Please delete or move existing sheets before" _ 
     & " copying data from the Master List.", vbCritical, _ 
     "Time Series Parser" 
     End 
    End If 

    Worksheets.Add(After:=Worksheets(Worksheets.Count)).name = name 
    Set tgt = Sheets(name) 

    ' copy header row from src to tgt 
    tgt.Range("A1:C1").Value = src.Range("A1:C1").Value 

    ' copy data from src to tgt 
    tgt.Range("A2:C" & Last - Start + 2).Value = _ 
     src.Range("A" & Start & ":C" & Last).Value 
End Sub 

Function SheetExists(name As String) As Boolean 
    Dim ws As Worksheet 

    SheetExists = True 
    On Error Resume Next 
    Set ws = Sheets(name) 
    If ws Is Nothing Then 
     SheetExists = False 
    End If 
End Function 

Answer 2

我試過這個代碼，它爲我工作。

這將分割數據（基於唯一的名稱），並將其粘貼到一個單獨的工作表將被命名爲相同的名字在列A

Sub SplitData() 
    Dim DataMarkers(), Names As Range, name As Range, n As Long, i As Long 

    Set Names = Range("A2:A" & Range("A1").End(xlDown).Row) 
    n = 0 

    DeleteWorksheets 

    For Each name In Names 
     If name.Offset(1, 0) <> name Then 
      ReDim Preserve DataMarkers(n) 
      DataMarkers(n) = name.Row 
      Worksheets.Add(After:=Worksheets(Worksheets.Count)).name = name 
      n = n + 1 
     End If 
    Next name 

    For i = 0 To UBound(DataMarkers) 
     If i = 0 Then 
      Worksheets(1).Range("A2:C" & DataMarkers(i)).Copy Destination:=Worksheets(i + 2).Range("A1") 
     Else 
      Worksheets(1).Range("A" & (DataMarkers(i - 1) + 1) & ":C" & DataMarkers(i)).Copy Destination:=Worksheets(i + 2).Range("A1") 
     End If 
    Next i 
End Sub 

Sub DeleteWorksheets() 
    Dim ws As Worksheet, activeShtIndex As Long, i As Long 

    activeShtIndex = ActiveSheet.Index 

    Application.DisplayAlerts = False 
    For i = ThisWorkbook.Worksheets.Count To 1 Step -1 
     If i <> activeShtIndex Then 
      Worksheets(i).Delete 
     End If 
    Next i 
    Application.DisplayAlerts = True 
End Sub 

我在做什麼在此代碼是：

1. 刪除所有的工作表除了一個與初始數據表
2. 工作向下「名稱」欄和創建的「標誌物」，其指示陣列，其中每一個數據分割是
3. 創建一個新的工作表並根據數組中的值將數據複製到它