PDA

View Full Version : [SOLVED] help needed to adjust a macro



Ger
01-06-2014, 04:20 AM
can somebody help me to adjust this macro. In the past the sheets where named 01 to 52. Now its wk01 to wk52. I cann't find a way to adjust the macro to get it work.



Sub CreateXRef()
Dim i As Long, j As Long, k As Long
Dim LastCol As Long
Dim LastRow As Long
Dim NextRow As Long
Dim FoundRow As Long
Dim sh As Worksheet

Application.ScreenUpdating = False

Application.DisplayAlerts = False
On Error Resume Next
Worksheets("output").Delete
On Error GoTo 0
Application.DisplayAlerts = True

Set sh = Worksheets.Add(before:=Worksheets(1))
sh.Name = "output"
sh.Range("A2").Value = "Name:"
NextRow = 1

For k = 1 To 52
With Worksheets(Format(k, "00"))
For j = 2 To 8

LastRow = .Cells(.Rows.Count, j).End(xlUp).Row
For i = 5 To LastRow
FoundRow = 0
On Error Resume Next
FoundRow = Application.Match(.Cells(i, j).Value2, sh.Columns("B"), 0)
On Error GoTo 0
If FoundRow = 0 Then

NextRow = NextRow + 1
sh.Cells(NextRow, "B").Value2 = .Cells(i, j).Value2
FoundRow = NextRow
End If

LastCol = sh.Cells(FoundRow, sh.Columns.Count).End(xlToLeft).Column
sh.Cells(FoundRow, LastCol + 1).Value2 = CDate(.Cells(4, j).Value2)
sh.Cells(FoundRow, LastCol + 1).NumberFormat = .Cells(4, j).NumberFormat
Next i
Next j
End With
Next k

Application.ScreenUpdating = True

End Sub

Aflatoon
01-06-2014, 04:27 AM
Change:
With Worksheets(Format(k, "00"))

to:
With Worksheets("wk" & Format(k, "00"))

Ger
01-06-2014, 04:39 AM
Thx for the quick help. This works.
There is now a new problem. On page wk15 and further there is text on row 20. Now the macro gives on the sheet output the first date (15 times) of the week. I only need the names in rows 5 to 19 but if i adjust the macro


LastRow = .Cells(.Rows.Count, j).End(xlUp).Row
For i = 5 To LastRow

to for I = 5 to 19 i get the first day of the week in the sheet output for every week 15 times.

Ger

Bob Phillips
01-06-2014, 04:55 AM
How about changing


LastRow = .Cells(.Rows.Count, j).End(xlUp).Row

to


LastRow = .Cells(20, j).End(xlUp).Row

Ger
01-06-2014, 05:00 AM
Thx.

All works fine now.


Ger