How To Copy & PasteSpecial: Range from Mult Wksht into SummarySheet

[Mike Taylor]

My workbook contains 100 wource wkshts identical except for contents
of cells. My code adds a new "Summary" wksht where I want to be able
to paste values and numbers only from the same range in each of the
other 100 wkshts in the wkbook. I want to loop thru each sht in the
workbook and:

1) Unprotect the source sht (password is "mbt"), then
2) Select a range ("G256:AD259") in the source sht, then
3) Paste only the cell values and number formats from that range into
the "Summary" wksht starting in cell "c3", then
4) place the name of the source sht in cell "b3", then
4) Go to next source wksht, copy the same range ("G256:AD259), and
paste those cell values and number formats into the next blank row
below what was just pasted, and
6) Continue the process until the copyrange & paste special has looped
thru all of the 100 source wksht.

I have gathered snipets of code that seem to almost work, but the use
of destination cell seems inappropriate for PasteSpecial purposes.
What I want to do is: Go to first source wksht - CopyRange - go to
cell "c3" in "Summary" and PasteValuesAndNumberFormat - place source
the wksht name for that source wksht into cell "b3" of "Summary", and
then loop through all of the remaining worksheets. Can someone correct
my code? TIA

Mike Taylor

---------------------------------------------------------------------------

Sub SummaryWkshtsAll()

Dim sht As Worksheet
Dim SummSht As Worksheet
Dim destCell As Range
Dim CopyRange As Range
Dim iRow As Long
Dim testRange As Range

Set SummSht = ActiveWorkbook.Sheets.Add
SummSht.Name = "0Summary"
Set destCell = SummSht.Range("b4")

For Each sht In ActiveWorkbook.Worksheets
With sht
If .Name <> "Summary" Then
If Not IsEmpty(.Range("a256")) Then
Set CopyRange = .Range("g256:ad" & .Cells(259,
"G").End _(xlUp).Row) '.Range("g256", .Range("g256").End(xlDown))

'Set CopyRange = .Range("G256:AD259")
For iRow = 257 To 259
Set testRange = .Range(.Cells(iRow, "G"),
..Cells _(iRow, "AD"))
If Application.CountG(testRange) > 0 Then
Set CopyRange = Union(CopyRange, testRange)
End If
Next iRow
'Set testRange = Intersect(CopyRange, .Columns(1))
destCell.Offset(0,
-1).Resize(CopyRange.Cells.Count, _ 1).Value = .Name
CopyRange.Copy Destination:=destCell
Set destCell = SummSht.Cells(SummSht.Rows.Count,
"b").End(xlUp).Offset(1, 0)
End If
End If
End With
Next sht
End Sub

 

[Ron de Bruin]

Look here and post back if you need more help
http://www.rondebruin.nl/copy2.htm

 

[Mike Taylor]

Ron, et. al.,

Got started with code I located at your link, but am still having
trouble. Can someone please help?

I am trying to copy ranges of each sheets in a wkbk into a single
sheet in the same wkbk. Here's what I am trying to do:

1) Create a sheet named "MSR", then loop thru each sheet in the wrkbk
where name > "000" and do the following:
2) Copy range "A5184" from the first sheet, "001", into cell "C3";
then
3) Copy range "E51:E84" into cell "G3", then
4) Place the sheet name into cell "C2", then repeat #3 and #4 in the
ranges to the right so that I have captured the data from each sh in
the wrkbk.

Here's the code I have so far...any help is appreciated in advance.

Option Explicit
____________________________________________________________________________
Function Lastcol(sh As Worksheet)
On Error Resume Next
Lastcol = sh.Cells.Find(What:="*", _
After:=sh.Range("B1"), _
Lookat:=xlPart, _
LookIn:=xlFormulas, _
SearchOrder:=xlByColumns, _
SearchDirection:=xlPrevious, _
MatchCase:=False).Column
On Error GoTo 0
End Function
____________________________________________________________________________
Sub MktgSourceClss()
Dim sh As Worksheet
Dim DestSh As Worksheet
Dim Last As Long

On Error Resume Next
If Len(ThisWorkbook.Worksheets.Item("MSC").Name) = 0 Then
On Error GoTo 0
Application.ScreenUpdating = False
Set DestSh = Worksheets.Add
DestSh.Name = "(MSC)"
For Each sh In ThisWorkbook.Worksheets
If sh.Name > "000" Then
Last = Lastcol(DestSh)

'sh.Range("A51:E84").Copy DestSh.Cells.Range("C3")

'sh.Range("D5184").Copy DestSh.Columns(Last + 1)
'sh.Range("D5184").Copy DestSh.Cells(Last + 3, "F")
'Instead of this line you can use the code below to
copy only the values
'or use the PasteSpecial option to paste the format
also.

'With sh.Range("D5184")
'DestSh.Columns(Last + 1).Resize(.Rows.Count,
..Columns.Count).Value = .Value
'End With

sh.Range("D5184").Copy
With DestSh.Columns
'DestSh.Columns(Last + 1).Resize_(.Rows.Count,
..Columns.Count).Value = .Value
.PasteSpecial xlPasteValues, , False, False
.PasteSpecial xlPasteFormats, , False, False
Application.CutCopyMode = False
End With

'DestSh.Cells(Last + 1, "F").Value = sh.Name
'This will copy the sheet name in the D column if you
want

End If

Next
Cells(1).Select
Application.ScreenUpdating = True
Else
MsgBox "The sheet Master already exist"
End If
End Sub