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

Question

到目前为止，根据其他人提出的问题，我有以下代码。

我有一组列在A列的名字，以及216列9725行的数据。

目前使用以下代码，我创建了新的 sheets，但除了唯一名称及其相关数据外，我得到了许多填充有“#N/A”的单元格。

在某些情况下，例如，名称 Bob 将填充在名为 Bob 的新 sheet 中，但第一列将包含 Bob 和所有相关数据，一旦显示所有 Bobs 行，它就是关注者，其中有许多带有#N/A 的行和带有#N/A 的所有列。

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

我希望每个人 sheet 只拥有基于 sheet 上的人名的信息。当我验证了填充的准确单元格的数量时，所有数据都被复制了，但我得到了这些#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 .

我想如果其他人正在寻找类似的代码，看看该站点会有所帮助。

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

I need to create new sheets based on unique names found in column A. Current Code generates excess data in certain sheets

excel

vba

excel-2010