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

Question

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

我希望执行以下操作。

为要添加的新工作表创建一个新工作簿 循环 AB:BE 并在新工作簿中创建一个新工作表，以列标题名称作为工作表名称 过滤此列（例如：AB）以仅包含此列表中的数据而不是空白 将此列数据（以 AB 为例）复制到此新工作表中 还将原始工作表中的 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