Question

我的报告中有一张表格显示的内容如下：

Agent Name   Acct Number   data     data     data   etc.

Alex         213           data     data     data   etc.

Alex         123           data     data     data   etc.

Alex         4334          data     data     data   etc.

David        23432         data     data     data   etc.

David        2342          data     data     data   etc.

Angel        1111          data     data     data   etc.

Angel        1111          data     data     data   etc.

首先，我创建一个主模板的副本，该副本存储在一个单独的工作表中。然后我将其命名为数组中第一个人的名字。

For z = 2 To jLastRow

    Sheets("Template").copy After:=Sheets(Sheets.Count)
    ActiveSheet.name = MyNames(i) '~~> retrieve from array

    Sheets("From DB Report").Activate

     While MyNames(i) = MyNames(i + 1)

        For Each myrange In Range("a2", Range("a60000").End(xlUp))

                Rows(myrange.Row).EntireRow.copy
                Sheets(MyNames(i)).Cells(myrange.Row * 2, 1).PasteSpecial xlValues
                i = i + 1
                If MyNames(i) <> MyNames(i + 1) Then MyNames(i) = MyNames(i + 1)

                Exit For                        

        Next myrange
    Wend


 Next

我想要做的是将选中的整行复制到新工作表。然后我想继续循环，而第一个人（myNames（i））仍然是相同的并继续复制该数据的行。

然后我需要做的是对数组中的其他名称执行完全相同的操作。我希望最终得到每个名称的表格和所有复制过的数据（按行）。

我让副本表工作，但我似乎无法将行复制过来。只有一行副本。任何帮助都会非常感激!!

更新：我的IT部门刚给了我这组代码，它在列表中的第一个名称上运行，但它不会继续循环，直到它找到要复制和重命名的下一个不同名称。

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

    Worksheets("From DB Report").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 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 <> " " 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
    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("Template").Activate

    ' Worksheets.Add(after:=Worksheets(Worksheets.Count)).name = name
    Worksheets("Template").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 Worksheet

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

这似乎取消了一系列名称。如果需要，我将如何浏览列表并使用唯一名称填充数组，然后解析要复制的行？

再次感谢！

Answer 1

您编写以下代码，每次都会执行Exit For语句。

            If MyNames(i) <> MyNames(i + 1) Then MyNames(i) = MyNames(i + 1)

            Exit For

如果您只想退出循环MyNames(i) <> MyNames(i+1)，则需要在下面写一下：

            If MyNames(i) <> MyNames(i + 1) Then 
                MyNames(i) = MyNames(i + 1)
                Exit For
            End If

更新

我重写了两个程序，

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

如果可能，你不应该依赖'On Error Resume Next'。

接下来，CopyDataToSheets程序，你没有比较cell.Value和Series。因此，Macro尝试在每一行中复制（并创建新工作表）。

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

在我的Excel中，这看起来很好。你的数据怎么样？

如何从同一列中具有多个条目的工作表复制行

1 个答案: