Macro only relating to one column

[icklemiller]

Hi guys...wondering if you can help?

I've got a macro here that is creating a summary sheet for me- it returns the data from one column only- column B- wondering how it can be changed to return the data from columns B thru K inclusive.

I'm a total novice here, so any info is appreciated

The code i have sofar is as below:

Sub JobSummary()
Dim wsSum As Worksheet
Dim rg_S As Range, rg_M As Range, rg_J As Range, rg_B As Range, rg_P As Range, rg_D As Range
Dim inJob As Integer
Dim c As Range
Dim ws As Worksheet

Application.ScreenUpdating = False

' ENSURE SUMMARY SHEET EXISTS
On Error Resume Next
With ThisWorkbook
Set wsSum = .Worksheets("Summary")
If wsSum Is Nothing Then
Set wsSum = .Worksheets.Add
wsSum.Name = "Summary"
End If
End With

On Error GoTo EH:

With wsSum
' PREP SUMMARY SHEET
.UsedRange.ClearContents
.Range("A1").Value = "S Stage"
.Range("B1").Value = "M Stage"
.Range("C1").Value = "J Stage"
.Range("D1").Value = "B Stage"
.Range("E1").Value = "P Stage"
.Range("F1").Value = "D Stage"
' SET JOB STAGE RANGES
Set rg_S = .Range("A2")
Set rg_M = .Range("B2")
Set rg_J = .Range("C2")
Set rg_B = .Range("D2")
Set rg_P = .Range("E2")
Set rg_D = .Range("F2")
End With

stStage = "A:A" 'Job Stage Column; in this example, Column A
inJob = 1 'Job Name column # - Job Stage column #; in this example, Job names are in Column B

' Loop through workbook, copying job names from each sheet to the correct column stage on the summary sheet
For Each ws In ThisWorkbook.Worksheets
If ws.Name <> wsSum.Name Then
' Loops through each cell in the job stage column
For Each c In Intersect(ws.UsedRange, ws.Range(stStage))
If InStr(1, "smjpbpd", c.Value, vbTextCompare) > 0 Then c.Offset(0, inJob).Copy

' Copies job name to the correct column stage
Select Case c.Value
Case "s"
rg_S.PasteSpecial
Set rg_S = rg_S.Offset(1, 0)
Case "m"
rg_M.PasteSpecial
Set rg_M = rg_M.Offset(1, 0)
Case "j"
rg_J.PasteSpecial
Set rg_J = rg_J.Offset(1, 0)
Case "b"
rg_B.PasteSpecial
Set rg_B = rg_B.Offset(1, 0)
Case "p"
rg_P.PasteSpecial
Set rg_P = rg_P.Offset(1, 0)
Case "d"
rg_D.PasteSpecial
Set rg_D = rg_D.Offset(1, 0)
End Select
Next c
End If
Next ws

EH:
Application.ScreenUpdating = True

With Err
If .Number <> 0 Then MsgBox "Oops! There is an error! Conduct error checking!"
.Clear
End With

Set c = Nothing
Set ws = Nothing
Set wsSum = Nothing
Set rg_S = Nothing
Set rg_M = Nothing
Set rg_J = Nothing
Set rg_B = Nothing
Set rg_P = Nothing
Set rg_D = Nothing

End Sub

Thanks again...

 

[icklemiller]

got it solved...