Copying a Range from Multiple Worksheets

[E-on]

I have posted it in other forms, but have not got any answer. I hop
Banters would do the magic for me.

I have got the following code from Ron de Bruin’s site. I would lik
to make an adjustment to this code, but got stuck. Change to be made i
highlighted in yellow. After all copies from individual sheets are don
in the destination sheet, I would like the name of each files to appea
in Column “A” of destination sheet not in Column “H” as per Ron’s code
I have added the following line, in order to insert a new column i
Column “A”. Please help.

DestSh.Columns("A:B").Insert Shift:=xlToRigh

Sub CopyRangeFromMultiWorksheets()
Dim sh As Worksheet
Dim DestSh As Worksheet
Dim Last As Long
Dim CopyRng As Range

With Application
.ScreenUpdating = False
.EnableEvents = False
End With

' Delete the summary sheet if it exists.
Application.DisplayAlerts = False
On Error Resume Next
ActiveWorkbook.Worksheets("RDBMergeSheet").Delete
On Error GoTo 0
Application.DisplayAlerts = True

' Add a new summary worksheet.
Set DestSh = ActiveWorkbook.Worksheets.Add
DestSh.Name = "RDBMergeSheet"

' Loop through all worksheets and copy the data to the
' summary worksheet.
For Each sh In ActiveWorkbook.Worksheets
If sh.Name <> DestSh.Name Then

' Find the last row with data on the summary worksheet.
Last = LastRow(DestSh)

' Specify the range to place the data.
Set CopyRng = sh.Range("A1:G1")

' Test to see whether there are enough rows in the summary
' worksheet to copy all the data.
If Last + CopyRng.Rows.Count > DestSh.Rows.Count Then
MsgBox "There are not enough rows in the " & _
"summary worksheet to place the data."
GoTo ExitTheSub
End If

' This statement copies values and formats from each
' worksheet.
CopyRng.Copy
With DestSh.Cells(Last + 1, "A")
.PasteSpecial xlPasteValues
.PasteSpecial xlPasteFormats
Application.CutCopyMode = False
End With

' Optional: This statement will copy the sheet

' name in the H column. I would like the name of the shee
to be in Column A of destination sheet, instead of Column H. I hav
inserted the following line and changed the Column “H” in to “A”, bu
the code stopped working.


My Addition DestSh.Columns("A:B").Insert Shift:=xlToRight


DestSh.Cells(Last + 1, "H").Resize(CopyRng.Rows.Count).Valu
= sh.Name

End If
Next

ExitTheSub:

Application.Goto DestSh.Cells(1)

' AutoFit the column width in the summary sheet.
DestSh.Columns.AutoFit

With Application
.ScreenUpdating = True
.EnableEvents = True
End With
End Su

 

[isabelle]

hi E-on,

Last = LastRow(DestSh)

can you show the function "LastRow"

--
isabelle



Le 2012-05-31 15:21, E-on a écrit :

 

[E-on]

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

Function LastCol(sh As Worksheet)
On Error Resume Next
LastCol = sh.Cells.Find(What:="*", After:=sh.Range("A1")
Lookat:=xlPart, LookIn:=xlFormulas, _
SearchOrder:=xlByColumns
SearchDirection:=xlPrevious, MatchCase:=False).Column
On Error GoTo 0

Isabelle! Thank you for your help!

The lastrow was a function. Please see above

 

[isabelle]

hi E-on,

replace
With DestSh.Cells(Last + 1, "A")

by
With DestSh.Cells(Last + 1, "B")

and

replace
DestSh.Cells(Last + 1, "H").Resize(CopyRng.Rows.Count).Value = sh.Name

by
DestSh.Cells(Last + 1, "A").Resize(CopyRng.Rows.Count).Value = sh.Name

--
isabelle



Le 2012-06-03 12:19, E-on a écrit :

 

[E-on]

isabelle! Thank you very much. I have changed the lines and is no
working the way I wanted it