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

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.

If you've done it with rows you can do it with columns too. Just use an offset function to shift over rows. Or use range(.cells(1,1),.cells(10,10)) to reference columns by numbers — gtwebb

GlennFromIowa GlennFromIowa · Accepted Answer · 2014-10-19T12:29:25

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

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

1 Answers