Question

我正在尝试将数据行复制到新工作表中。我有一个包含代理商名称和总销售额的清单。

对于此问题，必须至少有15个不同的主题，但我尝试的所有内容都会导致错误。

我只想将一行复制一行并将其复制到下一行。奇怪的是它今天早些时候实际上工作了!!

希望它只是一些我想念的简单。

    Set objWorksheet = ThisWorkbook.Worksheets("Control")
    Set rng = objWorksheet.Range("A1:A" & objWorksheet.Cells(Rows.Count, "A").End(xlUp).Row)

Sheets("Control").Select
Range("A2").Select

    Do Until IsEmpty(ActiveCell)

        strAgent = ActiveCell.Value

            For Each rngCell In rng.Cells

                objWorksheet.Select



                    If rngCell.Value = strAgent Then
                        rngCell.EntireRow.Copy
                        Set objNewSheet = Worksheets(strAgent)
                        objNewSheet.Select
                        objNewSheet.Range("A2:G1000").ClearContents
                        Set rngNextRow = objNewSheet.Range("A1:A" & objNewSheet.Cells(Rows.Count, "A").End(xlUp).Row)
                        Range("A" & rngNextRow.Rows.Count + 1).Select
                        objNewSheet.Paste


                    End If

            Next rngCell

        ActiveCell.Offset(1, 0).Select

    Loop

提前致谢！

编辑：

当我删除明确内容部分时，代码似乎有效。但是现在它似乎在尝试转移到下一个代理数据和工作表之前反复复制相同的数据（7次）。

Answer 1

代码中有太多“选择”，这可能（实际上总是如此）导致失去对你所引用内容的控制。

考虑以下代码的“修订版”

Option Explicit

Sub MySub()

Dim strAgent As String
Dim iFirst As Long, iLast As Long

With ThisWorkbook.Worksheets("Control")
    With .Range("A1", .Cells(.Rows.Count, "A").End(xlUp)).CurrentRegion 'sets the range containing data, headers included

        .Sort key1:=.Columns(1), Order1:=xlAscending, Orientation:=xlTopToBottom, Header:=xlYes ' sort data to have all same agents name rows grouped one after another

        ' now scan the agents name column to group each first and last occurrence of every name
        iFirst = 2
        Do While iFirst <= .Rows.Count

            strAgent = .Cells(iFirst, 1) 'set current agent name
            iLast = iFirst
            'skip rows until agent next agent name
            Do While .Cells(iLast + 1, 1) = strAgent
                iLast = iLast + 1
            Loop

            'copy the range form the first occurrence to the last one of the current agent name
            .Rows(iFirst).Resize(iLast - iFirst + 1).Copy
            'paste to the correspondant sheet in the first free cell of column "A"
            With ThisWorkbook.Worksheets(strAgent)
                .Cells(.Rows.Count, 1).End(xlUp).Offset(1).PasteSpecial xlPasteAll
            End With

            iFirst = iLast + 1 'skip to the next agent name
        Loop

    End With
End With


End Sub

我在哪里

假设所有数据都从单元格“A1”开始，位于连续列中，并且至少通过空白列和行分隔可能的其他数据
避免不必要地跳过表格：
- 对代理名称进行排序
- 扫描已排序的名称列，以“块”

还有许多其他方法（“过滤”会更优雅，但确实如此）这是直接有效的，以便有一个快速启动

无法将EntireRow复制到新工作表 - VBA - Excel - 工作表类的粘贴方法失败

1 个答案: