分离数据并放入单独的工作表Excel VBA [关闭]

2 回答

• 3

  如果要录制宏以查看发生的情况，请按照下列步骤操作：

  • 打开宏录制器

  • 按名称对数据排序

  • 从第一个名称复制数据

  • 将其粘贴到另一张纸上（如果需要另一张纸，请添加一张纸）

  • 为工作表命名

  • 重复下一个名字

  我还编写了一些可用于入门的代码 . 为此，您需要将数据选项卡命名为“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
  

  回复于 2024-05-04T07:24:38+08:00
• 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
  

  我在这段代码中所做的是：

  • 删除除具有初始数据表的工作表之外的所有工作表

  • 处理'Name'列并创建一个'markers'数组，指示每个数据拆分的位置

  • 创建一个新工作表，并根据数组中的值将数据复制到该工作表

  回复于 2024-05-04T07:24:38+08:00