Question

我正在尝试在Excel中使用VBA将行分成单独的表并保留标题。以下是我到目前为止的情况。它工作，除了我得到标题行，然后我想要移动到工作表的单个行是那里但它有三次而不是一次。我基本上是经过反复试验而且我很难过。请帮忙！我对此没有经验：

Sub DispatchTimeSeriesToSheets()
Dim ws As Worksheet
Set ws = Sheets("Scoring")
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
SortScoring LastRow, ws
CopyDataToSheets LastRow, ws
ws.Select
Application.ScreenUpdating = True
End Sub

Sub SortScoring(LastRow As Long, ws As Worksheet)
ws.Range("A4:W" & LastRow).Sort Key1:=ws.Range("A4"), Key2:=ws.Range("W4")
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("A4: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 Scoring.", 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:W1").Value = src.Range("A1:W1").Value

' copy data from src to tgt
tgt.Range("A4:W" & Last - Start + 2).Value = _
    src.Range("A" & Start & ":W" & 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 1

这将做你想要的

Const HeaderRow = 3
Sub MoveRecordsByValues()
Dim ws As Worksheet
Dim dws As Worksheet
Dim SheetName As String

Application.DisplayAlerts = False
For Each ws In Sheets
If ws.name <> "Scoring" Then ws.Delete
Next ws
Set ws = Sheets("Scoring")
StartRow = HeaderRow + 1
LastRow = ws.Range("A" & ws.Rows.Count).End(xlUp).Row

For RowCounter = StartRow To LastRow
    SheetName = ws.Cells(RowCounter, 1)
    If Not SheetExists(SheetName) Then SetUpSheet SheetName, ws, HeaderRow
    Set dws = Worksheets(SheetName)
    DestLastRow = dws.Range("A" & dws.Rows.Count).End(xlUp).Row + 1
    ws.Rows(RowCounter).Copy dws.Cells(DestLastRow, 1)
Next RowCounter
Application.DisplayAlerts = True
End Sub

Function SheetExists(name As String) As Boolean
    SheetExists = True
    On Error GoTo errorhandler
    Sheets(name).Activate
    Exit Function
errorhandler:
    SheetExists = False
End Function

Sub SetUpSheet(name, SourceSheet, HeaderRow)
    Dim DestSheet As Worksheet
    Set DestSheet = Sheets.Add
    DestSheet.name = name
    SourceSheet.Rows(1).Copy DestSheet.Cells(1, 1)
    SourceSheet.Rows(2).Copy DestSheet.Cells(2, 1)
    SourceSheet.Rows(3).Copy DestSheet.Cells(3, 1)
End Sub

Answer 2

试试这个：

Sub doitall()
Dim ows As Worksheet
Dim tws As Worksheet
Dim rng As Range
Dim cel As Range
Dim LastRow As Long
Dim tLastRow As Long

Set ows = Sheets("Scoring")

With ows
    LastRow = .Range("A" & .Rows.Count).End(xlUp).Row
    Set rng = .Range("A4:A" & LastRow)
    For Each cel In rng
        If Not SheetExists(cel.Value) Then
            Set tws = Worksheets.Add(After:=Sheets(Worksheets.Count))
            tws.Name = cel.Value
            tws.Rows(1).Resize(3).Value = .Rows(1).Resize(3).Value
        Else
            Set tws = Sheets(cel.Value)
        End If
        tLastRow = tws.Range("A" & tws.Rows.Count).End(xlUp).Offset(1).Row
        tws.Rows(tLastRow).Value = .Rows(cel.Row).Value
    Next
End With

End Sub
 Function SheetExists(SName As String, _
                     Optional ByVal WB As Workbook) As Boolean

    On Error Resume Next
    If WB Is Nothing Then Set WB = ActiveWorkbook
    SheetExists = CBool(Len(WB.Sheets(SName).Name))
End Function

将Excel行分隔为单独的工作表并保留标题

2 个答案: