More used range Q's


K

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
 
Ad

Advertisements

N

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

'<<=================
 
K

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
 
N

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!
 
Ad

Advertisements


Ask a Question

Want to reply to this thread or ask your own question?

You'll need to choose a username for the site, which only take a couple of moments. After that, you can post your question and our members will help you out.

Ask a Question

Top