Want to add additional columns to attached macro please

[007juk]

Hi,

Can someone help please. I don't know how to add addtional columns to the attached macro. At the moment when I run macro it provides me with one column of data with a heading. Want to add an extra four columns. The titles of columns can be col2, col3, col4 and col6.

Many thanks.

Sub ListTraining()
Dim LastRow As Long, i As Long, StartRow As Long, NameCol As Integer
Dim ISh As Worksheet, OSh As Worksheet, j As Long
StartRow = 2
NameCol = 1
Set ISh = ActiveSheet
LastRow = ISh.Cells(Rows.Count, NameCol).End(xlUp).Row
Application.DisplayAlerts = False
On Error Resume Next
Sheets("Need Training").Delete
On Error GoTo 0
Application.DisplayAlerts = True
Worksheets.Add(After:=Worksheets(Worksheets.Count) ).Name = "Need Training"
Set OSh = Sheets("Need Training")
OSh.Cells(1, 1).Value = "Training overdue for Manual Handling"
j = 1
For i = StartRow To LastRow
If IsEmpty(ISh.Cells(i, NameCol + 1).Value) Then
j = j + 1
OSh.Cells(j, 1).Value = ISh.Cells(i, NameCol).Value
End If
Next i
OSh.Columns(1).EntireColumn.AutoFit
End Sub

 

[stanleydgromjr]

007juk,

Here you go:

Option Explicit
Sub ListTraining()
    Dim LastRow As Long, i As Long, StartRow As Long, NameCol As Integer
    Dim ISh As Worksheet, OSh As Worksheet, j As Long
    StartRow = 2
    NameCol = 1
    Set ISh = ActiveSheet
    LastRow = ISh.Cells(Rows.Count, NameCol).End(xlUp).Row
    Application.DisplayAlerts = False
    On Error Resume Next
    Sheets("Need Training").Delete
    On Error GoTo 0
    Application.DisplayAlerts = True
    Worksheets.Add(After:=Worksheets(Worksheets.Count)).Name = "Need Training"
    Set OSh = Sheets("Need Training")
    OSh.Cells(1, 1).Value = "Training overdue for Manual Handling"
    'Want to add an extra four columns. The titles of columns can be col2, col3, col4 and col6.
    OSh.Cells(1, 2).Value = "col2"
    OSh.Cells(1, 3).Value = "col3"
    OSh.Cells(1, 4).Value = "col4"
    OSh.Cells(1, 5).Value = "col6"
    j = 1
    For i = StartRow To LastRow
        If IsEmpty(ISh.Cells(i, NameCol + 1).Value) Then
            j = j + 1
            OSh.Cells(j, 1).Value = ISh.Cells(i, NameCol).Value
        End If
    Next i
    OSh.Columns(1).EntireColumn.AutoFit
End Sub

Have a great day,
Stan

 

[boylejob]

This is a cross post

http://www.excelforum.com/showthread.php?t=608621