loop through columns on worksheet, copy data to new worksheet in new workbook - im stuck - vba

Question

I have a workbook that consists of several worksheets all with the same column headers. The rows in each worksheet identify an employee task and other task information. Columns starting at AB - BE containing an employee’s title as the column name along with email address in the row if they assisted in that task. Some of the rows are in a particular column if that employee roll has not touched that task.
I am looking to do the following.
Create a new workbook for new worksheets to be added
Loop through AB:BE and create a new worksheet in the new workbook with the column header name as the worksheet name
Filter this column (example: AB) to only include data that is in this list and not blanks
Copy this column data (AB as an example) into this new worksheet
Also copy Rows B, F, H from original worksheet to this new worksheet
Clear the filters on the main worksheet
Loop to next column (example AC) , repeat with creation of new worksheet in the workbook
I have done this in the past with rows just fine – I am having issues conceptually thinking about how this should work.
Does anyone have any examples? I have searched google for a few days and can get close in some areas however it does not scale well / loop on the data well.

Answer 1

Note: This could also be done with an Advanced Filter. That allows a filtered range to be copied to a new sheet.
I'm not sure I'm entirely understanding the sheet layout, but here's some basic code to create a new sheet for each column AB:BE, then for each row in column AB that is not empty, copy that cell value, along with the value in columns B, F, and H to a row in that new worksheet. Repeating then for columns 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