More used range Q's

[Kstalker]

I am trying to copy the used range from a specified selection o
worksheets, this time within
one workbook. I only want to take the header row from one sheet and no
from the rest. I have used the helpful tip outlined below (only segmen
of code) but it copies all worksheets within the workbook with al
headers included.


Sub CopyUsedRange()
Dim sh As Worksheet
Dim DestSh As Worksheet
Dim Last As Long
If SheetExists("Master") = True Then
MsgBox "The sheet Master already exist"
Exit Sub
End If
Application.ScreenUpdating = False
Set DestSh = Worksheets.Add
DestSh.Name = "Master"
For Each sh In ThisWorkbook.Worksheets
If sh.Name <> DestSh.Name Then
If sh.UsedRange.Count > 1 Then
Last = LastRow(DestSh)
sh.UsedRange.Copy DestSh.Cells(Last + 1, 1)
End If
End If
Next
Application.ScreenUpdating = True
End Sub

Similar to my other post but I have outlined more and refined m
direction.
Thanks in advance.

Krista

 

[Norman Jones]

Hi Kristan,

See Ron De Bruin's web site for a whole range of copy Cell(s) \ Range \
Sheet \ Workbook routines copy at:

http://www.rondebruin.nl/tips.htm

 

[Norman Jones]

Hi Kristan,

Looking again, I see that the code you show *is* Ron de Bruin's.

Try this adaptation of Ron's code (on a copy of your workbook!) and see if
it satisfies your requirements.

I have included the Ron's LastRow function and the Chip Pearson SheetExists
function for completenes and as these are required by the sub.

Sub CopyUsedRange()
Dim sh As Worksheet
Dim DestSh As Worksheet
Dim Last As Long
Dim RngToCopy As Range
Dim Arr As Variant
Dim WB As Workbook
Dim i As Long

Set WB = ActiveWorkbook '<<===== CHANGE or KEEP

Arr = Array("Sheet1", "Sheet2", "Sheet3") '<<==== CHANGE

If SheetExists("Master", WB) = True Then
MsgBox "The sheet Master already exist"
Exit Sub
End If

Application.ScreenUpdating = False
Set DestSh = WB.Worksheets.Add
DestSh.Name = "Master"

For i = LBound(Arr) To UBound(Arr)
Set sh = Sheets(Arr(i))

With sh.UsedRange

If i = 1 Then .Rows(1).Copy DestSh.Cells(1)

Set RngToCopy = .Offset(1).Resize(.Rows.Count - 1)
If i = 1 Then .Rows(1).Copy DestSh.Cells(1)

End With

If sh.UsedRange.Count > 1 Then
Last = LastRow(DestSh)
RngToCopy.Copy DestSh.Cells(Last + 1, 1)
End If

Next

Application.ScreenUpdating = True

End Sub
'<<=================

'=================>>
Function LastRow(sh As Worksheet)
On Error Resume Next
LastRow = sh.Cells.Find(What:="*", _
After:=sh.Range("A1"), _
Lookat:=xlPart, _
LookIn:=xlValues, _
SearchOrder:=xlByRows, _
SearchDirection:=xlPrevious, _
MatchCase:=False).Row
On Error GoTo 0
End Function


Function SheetExists(SName As String, _
Optional ByVal WB As Workbook) As Boolean
'Chip Pearson
On Error Resume Next
If WB Is Nothing Then Set WB = ThisWorkbook
SheetExists = CBool(Len(WB.Sheets(SName).Name))
End Function

'<<=================

 

[Kstalker]

Didn't intend on sounding like a plagarist, Ron de Bruin's code worked a
treat.

That adaptation is on the money, with one exception. Still misses the
first row on the first sheet. (not header) Otherwise pulls everything
together perfectly. Any idea how to include that initial row?

Thanks again
Kristan

 

[Norman Jones]

Hi Kristan,

In the line:

If i = 1 Then .Rows(1).Copy DestSh.Cells(1)

try changing i=1 to i=2.

Didn't intend on sounding like a plagarist, Ron de Bruin's code worked a
treat.

And no such intention on my part to suggest this. In any event, I am sure
that Ron is only too happy for his published code to be used.

The comment to which you have responded was a metaphoric wry smile at
myself: I advised you to look at Ron's code offerings and you already had!

 

[Norman Jones]

Hi Kristan,

Typo warning!

try changing i=1 to i=2.

should read:

try changing i=1 to i=0

..

 

[Kstalker]

All good.

Thanks for your knowledge and tenacity Norman.

Regards

Krista