Question

我有一个工作簿，其中包含多个具有相同列标题的工作表。每个工作表中的行标识员工任务和其他任务信息。从AB开始的列 - BE包含员工的标题作为列名称以及行中的电子邮件地址（如果他们协助完成该任务）。如果该员工卷未触及该任务，则某些行位于特定列中。

我希望做到以下几点。

为要添加的新工作表创建新工作簿循环AB：BE并在新工作簿中创建一个新的工作表，列标题名称作为工作表名称过滤此列（例如：AB）仅包含此列表中的数据而不是空白将此列数据（AB作为示例）复制到此新工作表中同时将Rows B，F，H从原始工作表复制到此新工作表清除主工作表上的过滤器

循环到下一列（示例AC），重复在工作簿中创建新工作表

我在过去做过这样的事情就好了 - 我在概念上思考这应该如何运作的问题。

有没有人有任何例子？我已经搜索了谷歌几天，并且可以在某些地区接近但是它不能很好地扩展/循环数据。

Answer 1

注意：这也可以使用高级过滤器完成。这样就可以将过滤范围复制到新工作表中。

我不确定我是否完全理解了工作表布局，但是这里有一些基本代码为每列AB创建一个新工作表：BE，然后对于AB列中非空的每一行，复制该单元格值，以及列B，F和H中的值到该新工作表中的一行。然后重复列AC：BE。

Sub CopyRoles()

Dim nSheet As Integer
Dim nTasks As Integer
Dim nSourceRow As Long
Dim nDestRow As Long
Dim wkb As Workbook
Dim wksSource As Worksheet
Dim wksDest As Worksheet

Set wksSource = ActiveSheet
Set wkb = Workbooks.Add
For nTasks = wksSource.Range("AB1").Column To wksSource.Range("BE1").Column
    nSheet = nTasks - wksSource.Range("AB1").Column + 1
    With wkb.Sheets
        If .Count < nSheet Then    ' Checks if sheet count on wkb exceeded
            Set wksDest = .Add(after:=.Item(.Count), Type:=xlWorksheet)
        Else
            Set wksDest = .Item(nSheet)    ' Keeps from having empty sheets
        End If
        wksDest.Name = wksSource.Cells(1, nTasks)
    End With

    With wksSource
        wksDest.Cells(1, 1) = "E-mail address"  ' Add header row to sheet
        wksDest.Cells(1, 2) = .Cells(.UsedRange.Row, 2)   ' Col B
        wksDest.Cells(1, 3) = .Cells(.UsedRange.Row, 6)   ' Col F
        wksDest.Cells(1, 4) = .Cells(.UsedRange.Row, 8)   ' Col H
        nDestRow = 2
        For nSourceRow = .UsedRange.Row + 1 To .UsedRange.Rows.Count
            If .Cells(nSourceRow, nTasks).Value <> "" Then
                wksDest.Cells(nDestRow, 1).FormulaR1C1 = _
                    .Cells(nSourceRow, nTasks).Value
                wksDest.Cells(nDestRow, 2).FormulaR1C1 = _
                    .Range("B" & nSourceRow).Value
                wksDest.Cells(nDestRow, 3).FormulaR1C1 = _
                    .Range("F" & nSourceRow).Value
                wksDest.Cells(nDestRow, 4).FormulaR1C1 = _
                    .Range("H" & nSourceRow).Value
                nDestRow = nDestRow + 1
            End If
        Next nSourceRow
    End With
Next nTasks

wkb.SaveAs

End Sub

循环遍历工作表上的列，将数据复制到新工作簿中的新工作表 - 我卡住了

1 个答案: