Consolidating worksheets into one and paste special

[winfy]

Hi all, I found the code to consolidate worksheets into one sheet, but have two questions I am hoping someone can help me with.

1) The sheets are formula based and I just want to paste special values. How can I do that? The code doesn't seem to provide me any way to add it in; and
2) For some reason, the input begins in the directory tab begins in A2, but I want it to begin in B7. All other sheets begin in B7 and I find it strange why it starts in A2.

Any help will be greatly appreciated.


Sub Combine()
Dim J As Integer
On Error Resume Next
Sheets(1).Select
Worksheets.Add ' add a sheet in first place

Sheets(1).Name = "Directory"


' copy headings
Sheets(2).Activate
Range("A1").EntireRow.Select
Selection.Copy Destination:=Sheets(1).Range("A1")
' work through sheets
For J = 2 To Sheets.Count ' from sheet 2 to last sheet
Sheets(J).Activate ' make the sheet active
Range("B10").Select
Selection.CurrentRegion.Select ' select all cells in this sheets
' select all lines except title
Selection.Offset(1, 0).Resize(Selection.Rows.Count - 1).Select
' copy cells selected in the new sheet on last line
Selection.Copy Destination:=Sheets(1).Range("A65536").End(xlUp)(2)
Next
End Sub

[Paul_Hossler]

1. Use the [#] icon to insert CODE tags. and paste you code between them for better formatting

2. I'd change the macro a little, but this is still not very robust code since some cells are hard coded

3. But you can play around with this




Option Explicit

Sub Combine()

Dim ws As Worksheet, wsDirectory As Worksheet
Dim rDest As Range, rSrc As Range

Set ws = Worksheets(1)
Worksheets.Add ws ' add a sheet in first place
Set wsDirectory = ActiveSheet
wsDirectory.Name = "Directory"

' copy headings
Call ws.Rows(1).Copy(wsDirectory.Rows(1))

For Each ws In Worksheets
If ws.Name <> wsDirectory.Name Then
Set rSrc = ws.Range("B10").CurrentRegion
' select all lines except title
Set rSrc = rSrc.Cells(2, 1).Resize(rSrc.Rows.Count - 1, rSrc.Columns.Count)
If Len(wsDirectory.Range("B7").Value) = 0 Then
Set rDest = wsDirectory.Range("B7")
Else
Set rDest = wsDirectory.Cells(wsDirectory.Rows.Count, 2).End(xlUp).Offset(1, 0)
End If

rSrc.Copy rDest
End If
Next
End Sub

[winfy]

Paul, thanks for your help.

I have a follow up question.

Once I create the directory tab, I will be adding additional tabs at a later point in time and I don't want to always re-create the directory tab because I'll be adding features etc to the directory tab. How can I just update the directory tab with additional tabs without having first to delete the directory tab?

Also, the code you provided doesn't include paste value only. It would be great if you can assist if possible.

[Paul_Hossler]

Try this then





Option Explicit
Sub Combine()
Dim ws As Worksheet, wsDirectory As Worksheet
Dim rDest As Range, rSrc As Range
Dim i As Long

Application.ScreenUpdating = False

'see if Directory sheet is there, create if not
i = -1
On Error Resume Next
i = Worksheets("Directory").Index
On Error GoTo 0

If i = -1 Then ' not there
Set ws = Worksheets(1)
Worksheets.Add ws ' add a sheet in first place
Set wsDirectory = ActiveSheet
wsDirectory.Name = "Directory"
' copy headings
Call ws.Rows(1).Copy(wsDirectory.Rows(1))
Else
Set wsDirectory = Worksheets("Directory")
End If

For Each ws In Worksheets
If ws.Name <> wsDirectory.Name Then
Set rSrc = ws.Range("B10").CurrentRegion
' select all lines except title
Set rSrc = rSrc.Cells(2, 1).Resize(rSrc.Rows.Count - 1, rSrc.Columns.Count)
If Len(wsDirectory.Range("B7").Value) = 0 Then
Set rDest = wsDirectory.Range("B7")
Else
Set rDest = wsDirectory.Cells(wsDirectory.Rows.Count, 2).End(xlUp).Offset(1, 0)
End If

rSrc.Copy
rDest.PasteSpecial xlPasteValues
End If
Next

Application.ScreenUpdating = True

End Sub