Solved: Help alter code to pickup extra info.

[Barryj]

I posted this workbook about a month ago and it works fine, but I need to pickup some extra data form it and place it on the destination sheet.

If week 1 is selected I need it to pickup the date from 1AA and place it in row 1 column 12 of destination sheet, if week 2 is selected then pickup the date from 1BC and place it in destination sheet row 1 column 12.

I tried to alter this myself without any luck, this is the code that is in the attachment.

Option Explicit
Sub Shows()
UserForm1.Show False
End Sub
Sub Test(ShNo As Long, Wk As Long, TSNo As Long)
Dim sh As Worksheet, Tsh As Worksheet
Dim i As Long, k As Long, Rw As Long, Oset As Long
Set sh = Sheets("Sheet" & ShNo)
On Error Resume Next
Set Tsh = Sheets("Time Sheet Week" & TSNo)
If Tsh Is Nothing Then
Sheets.Add after:=Sheets("Time Sheet Week" & TSNo - 1)
ActiveSheet.Name = "Time Sheet Week" & TSNo
Set Tsh = Sheets("Time Sheet Week" & TSNo)
End If
If Wk = 2 Then Oset = 28
For i = 4 To sh.Cells(Rows.Count, 1).End(xlUp).Row
With Tsh
.Cells(Rw + 1, 5) = sh.Cells(i, 2)
.Cells(Rw + 1, 8) = sh.Cells(i, 59)
For k = 0 To 6
.Cells(Rw + 2 + k, 2) = sh.Cells(i, 4 + Oset + (4 * k))
.Cells(Rw + 2 + k, 3) = sh.Cells(i, 5 + Oset + (4 * k))
.Cells(Rw + 2 + k, 7) = sh.Cells(i, 6 + Oset + (4 * k))
.Cells(Rw + 2 + k, 2).Interior.ColorIndex = 6
.Cells(Rw + 2 + k, 3).Interior.ColorIndex = 7
.Cells(Rw + 2 + k, 7).Interior.ColorIndex = 8
sh.Cells(i, 4 + (4 * k)).Interior.ColorIndex = 6
sh.Cells(i, 5 + (4 * k)).Interior.ColorIndex = 7
sh.Cells(i, 6 + (4 * k)).Interior.ColorIndex = 8
Next k
End With
Rw = Rw + 14
Next i
End Sub

Thanks for any assistance.

[rbrhodes]

Hi Barryj


Sub Test(ShNo As Long, Wk As Long, TSNo As Long)
Dim sh As Worksheet, Tsh As Worksheet
Dim i As Long, k As Long, Rw As Long, Oset As Long
Set sh = Sheets("Sheet" & ShNo)
On Error Resume Next
Set Tsh = Sheets("Time Sheet Week" & TSNo)
If Tsh Is Nothing Then
Sheets.Add after:=Sheets("Time Sheet Week" & TSNo - 1)
ActiveSheet.Name = "Time Sheet Week" & TSNo
Set Tsh = Sheets("Time Sheet Week" & TSNo)
End If
If Wk = 2 Then Oset = 28


'inserted lines
With Tsh
If Wk = 1 Then
'Col 12, Row 1 = AA1
.Cells(1, 12) = sh.Cells(1, 27)
Else
'Col 12, Row 1 = BC1
.Cells(1, 12) = sh.Cells(1, 55)
End If
'format as date, use any valid format
.Cells(1, 12).NumberFormat = ("MMM-DD-YYYY")
End With
'End insert

For i = 4 To sh.Cells(Rows.Count, 1).End(xlUp).Row
With Tsh
.Cells(Rw + 1, 5) = sh.Cells(i, 2)
.Cells(Rw + 1, 8) = sh.Cells(i, 59)
For k = 0 To 6
.Cells(Rw + 2 + k, 2) = sh.Cells(i, 4 + Oset + (4 * k))
.Cells(Rw + 2 + k, 3) = sh.Cells(i, 5 + Oset + (4 * k))
.Cells(Rw + 2 + k, 7) = sh.Cells(i, 6 + Oset + (4 * k))
.Cells(Rw + 2 + k, 2).Interior.ColorIndex = 6
.Cells(Rw + 2 + k, 3).Interior.ColorIndex = 7
.Cells(Rw + 2 + k, 7).Interior.ColorIndex = 8
sh.Cells(i, 4 + (4 * k)).Interior.ColorIndex = 6
sh.Cells(i, 5 + (4 * k)).Interior.ColorIndex = 7
sh.Cells(i, 6 + (4 * k)).Interior.ColorIndex = 8
Next k
End With
Rw = Rw + 14
Next i
End Sub

Cheers,
dr

[Barryj]

Thanks rbrodes, that picks up the extra info great, can it be made to put this info on each sheet in the destination sheet?

[Barryj]

help/:dunno

[rbrhodes]

Each destination sheet? I only see one in the code.

I guess an example with explanations?


cheers,

dr

[Barryj]

Sorry I meant each page of the destination sheet, as there are approx 80 pages that this would copy to, yhe attachment has about 5 pages.

Sorry for the confusion.

Thanks again:doh:

[rbrhodes]

Ahhh! More like this I take it?



Sub Test(ShNo As Long, Wk As Long, TSNo As Long)
Dim sh As Worksheet, Tsh As Worksheet
Dim i As Long, k As Long, Rw As Long, Oset As Long
Set sh = Sheets("Sheet" & ShNo)
On Error Resume Next
Set Tsh = Sheets("Time Sheet Week" & TSNo)
If Tsh Is Nothing Then
Sheets.Add after:=Sheets("Time Sheet Week" & TSNo - 1)
ActiveSheet.Name = "Time Sheet Week" & TSNo
Set Tsh = Sheets("Time Sheet Week" & TSNo)
End If
If Wk = 2 Then
Oset = 28
End If
For i = 4 To sh.Cells(Rows.Count, 1).End(xlUp).Row
With Tsh
.Cells(Rw + 1, 5) = sh.Cells(i, 2)
.Cells(Rw + 1, 8) = sh.Cells(i, 59)

'moved to here
'put date
.Cells(Rw + 1, 12) = sh.Cells(1, 27 + Oset)
'format as date, use any valid format
.Cells(Rw + 1, 12).NumberFormat = ("MMM-DD-YYYY")

For k = 0 To 6
.Cells(Rw + 2 + k, 2) = sh.Cells(i, 4 + Oset + (4 * k))
.Cells(Rw + 2 + k, 3) = sh.Cells(i, 5 + Oset + (4 * k))
.Cells(Rw + 2 + k, 7) = sh.Cells(i, 6 + Oset + (4 * k))
.Cells(Rw + 2 + k, 2).Interior.ColorIndex = 6
.Cells(Rw + 2 + k, 3).Interior.ColorIndex = 7
.Cells(Rw + 2 + k, 7).Interior.ColorIndex = 8
sh.Cells(i, 4 + (4 * k)).Interior.ColorIndex = 6
sh.Cells(i, 5 + (4 * k)).Interior.ColorIndex = 7
sh.Cells(i, 6 + (4 * k)).Interior.ColorIndex = 8
Next k
End With
Rw = Rw + 14
Next i
End Sub


Cheers.

dr

[Barryj]

Thanks rbrhodes, that working great thanks again for your help and patience on this, Cheers.

I will mark this as solved.