Code is modified by OP from Claus' original.

Why must I add 1 to the Inputbox entries to return the proper "Week"?

Without the + 1, entries of 2 and 4 return Week1 to Week3.

https://www.dropbox.com/s/lnjqgmpnlc...ader.xlsm?dl=0

Howard

Sub Week_Reader_A_revised()
'/ by Claus @ MS Public (Modified by OP)

Dim fWeek As Long, lWeek As Long, lRow As Long, i As Long
Dim myArr As Variant
Dim f As Range, l As Range, myRng As Range, wkRng As Range

fWeek = Application.InputBox("Enter the STARTING WEEK to search for", "Start Weeknumber", Type:=1) + 1
If fWeek = False Then Exit Sub

lWeek = Application.InputBox("Enter the ENDING WEEK to search for", "Last Weeknumber", Type:=1) + 1
If lWeek = False Then Exit Sub

Sheets("Master").UsedRange.ClearContents

myArr = Array("Bodypump", "Bodystep-step", "Y-Blitz", "Y-Chisel", "Y-Cycle", "Zumba")

Application.ScreenUpdating = False

For i = 0 To UBound(myArr)
Set myRng = Nothing
With Sheets(myArr(i))

Set f = .Range("A2:A100").Find(fWeek, LookIn:=xlValues, lookat:=xlPart)
Set l = .Range("A2:A100").Find(lWeek, LookIn:=xlValues, lookat:=xlPart)
If Not f Is Nothing Then
lRow = Sheets("Master").Cells(Rows.Count, 1).End(xlUp).Row

If lRow = 1 Then
Set wkRng = .Range(fWeek & ":" & lWeek)
Set myRng = Union(.Rows(1), wkRng)
myRng.Copy Sheets("Master").Range("A1")

Else

Set wkRng = .Range(fWeek & ":" & lWeek)
Set myRng = Union(.Rows(1), wkRng)
myRng.Copy Sheets("Master").Cells(lRow + 2, 1)

End If
End If
End With
Next

Sheets("Master").Columns("A:Z").AutoFit
Sheets("Master").Rows("1:200").AutoFit
Application.ScreenUpdating = True
End Sub

Hi Howard,

Am Wed, 25 Mar 2015 22:51:23 -0700 (PDT) schrieb L. Howard:

If lRow = 1 Then
Set wkRng = .Range(fWeek & ":" & lWeek)
^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
Set myRng = Union(.Rows(1), wkRng)
myRng.Copy Sheets("Master").Range("A1")

Else

Set wkRng = .Range(fWeek & ":" & lWeek)
^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
Set myRng = Union(.Rows(1), wkRng)
myRng.Copy Sheets("Master").Cells(lRow + 2, 1)

End If
End If
^
the mistake is in the lines above.
Change them to:

If lRow = 1 Then
Set wkRng = .Rows(f.Row & ":" & l.Row)
wkRng.Copy Sheets("Master").Range("A1")
Else
Set wkRng = .Rows(f.Row & ":" & l.Row)
wkRng.Copy Sheets("Master").Cells(lRow + 2, 1)
End If
End If



Regards
Claus B.
--
Vista Ultimate / Windows7
Office 2007 Ultimate / 2010 Professional

Hi Howard,

Am Thu, 26 Mar 2015 07:55:00 +0100 schrieb Claus Busch:

If lRow = 1 Then
Set wkRng = .Rows(f.Row & ":" & l.Row)
wkRng.Copy Sheets("Master").Range("A1")
Else
Set wkRng = .Rows(f.Row & ":" & l.Row)
wkRng.Copy Sheets("Master").Cells(lRow + 2, 1)
End If

sorry, forgot the headers:

If lRow = 1 Then
Set wkRng = .Rows(f.Row & ":" & l.Row)
Set myRng = Application.Union(.Rows(1), wkRng)
myRng.Copy Sheets("Master").Range("A1")
Else
Set wkRng = .Rows(f.Row & ":" & l.Row)
Set myRng = Application.Union(.Rows(1), wkRng)
myRng.Copy Sheets("Master").Cells(lRow + 2, 1)
End If


Regards
Claus B.
--
Vista Ultimate / Windows7
Office 2007 Ultimate / 2010 Professional

On Wednesday, March 25, 2015 at 11:59:03 PM UTC-7, Claus Busch wrote:
Hi Howard,

Am Thu, 26 Mar 2015 07:55:00 +0100 schrieb Claus Busch:

If lRow = 1 Then
Set wkRng = .Rows(f.Row & ":" & l.Row)
wkRng.Copy Sheets("Master").Range("A1")
Else
Set wkRng = .Rows(f.Row & ":" & l.Row)
wkRng.Copy Sheets("Master").Cells(lRow + 2, 1)
End If

sorry, forgot the headers:

If lRow = 1 Then
Set wkRng = .Rows(f.Row & ":" & l.Row)
Set myRng = Application.Union(.Rows(1), wkRng)
myRng.Copy Sheets("Master").Range("A1")
Else
Set wkRng = .Rows(f.Row & ":" & l.Row)
Set myRng = Application.Union(.Rows(1), wkRng)
myRng.Copy Sheets("Master").Cells(lRow + 2, 1)
End If


Regards
Claus B.


Oh boy, I would have never sorted that out.

Works mighty fine.

Thanks again.

Howard