我需要根据在A列中找到的唯一名称创建新工作表。“当前代码”在某些工作表中生成了多余的数据

Question

到目前为止，基于其他人的问题，我有以下代码。

我在A列中列出了一组名称，以及216列和9725行数据。

当前使用以下代码，我获得了创建的新工作表，除了唯一名称及其相关数据，我还获得了许多用“＃N / A”填充的单元格。

在某些情况下，例如Bob的姓名将填充在名为Bob的新工作表中，但第一列将包含Bob和所有相关数据，并且一旦显示了所有Bobs行，它就会成为具有许多行的＃N / A和所有列的跟随者＃N / A。

在其他情况下，将为Charles创建工作表，并列出所有Charles数据，然后列出许多行＃N / A，然后列出所有主数据，包括我需要避免的其他人的姓名。

我希望每个工作表仅包含基于该工作表上人员姓名的信息。 我验证了要填充的准确单元格的数量后，所有数据都被复制了，但是我得到了这些＃N / A单元格并重复了额外的数据，我不确定如何阻止它填充？ 任何帮助清除代码将不胜感激！

码：

Sub CopyDataFromReportToIndividualSheets()
Dim ws As Worksheet
Set ws = Sheets("FormulaMSheet2")
Dim LastRow As Long
Dim MyRange As Range

Worksheets("FormulaMSheet2").Activate

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:BO" & LastRow).Sort Key1:=ws.Range("A1") 
', Key2:=ws.Range("B1")
End Sub
Sub CopyDataToSheets(LastRow As Long, src As Worksheet)
Dim allAgentNameCells As Range
Dim cell As Range
Dim Series As String
Dim SeriesStart As Long
Dim SeriesLast As Long

Set allAgentNameCells = Range("A2:A" & LastRow)
SeriesStart = 2
Series = Range("A" & SeriesStart).Value

For Each cell In allAgentNameCells

    If cell.Value <> " " And cell.Value <> "" Then
        ' Condition ` And cell.Value <> "" ` added for my testdata. If you don't need this, please remove.

        ' Current Row's Series not SPACE

        If cell.Value <> Series Then
            SeriesLast = cell.Row - 1
            CopySeriesToNewSheet src, SeriesStart, SeriesLast, Series
            Series = cell.Value
            SeriesStart = cell.Row
        End If
    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
Dim MyRange As Range

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
Else
   If Series = " " Then
      End
   End If

End If

Worksheets("FormulaMSheet2").Activate

' Worksheets.Add(after:=Worksheets(Worksheets.Count)).name = name
Worksheets("FormulaMSheet2").Copy After:=Worksheets(Worksheets.Count)
ActiveSheet.name = name

Set tgt = Sheets(name)

' copy data from src to tgt
tgt.Range("A2:BO2" & Last - Start + 2).Value = src.Range("A" & Start & ":BO" & Last).Value


End Sub

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

For Each ws In ThisWorkbook.Sheets
    If ws.name = name Then

        SheetExists = True
        Exit Function

    End If
Next

SheetExists = False

End Function

Answer 1

您需要更换

tgt.Range("A2:BO2" & Last - Start + 2).Value = src.Range("A" & Start & ":BO" & Last).Value

至

src.Range("A" & Start & ":BO" & Last).SpecialCells(xlCellTypeVisible).Copy Destination:=tgt.Range("A2:BO2" & Last - Start + 2)

Answer 2

我在以下站点找到了所需的资源： http : //www.rondebruin.nl/win/s3/win006_5.htm 。

我认为，如果其他人正在寻找类似的代码，则有助于查看该站点。