D
dhermus
I am using a variation of the code from Ron DeBruin to merge multiple
worksheets into one worksheet. When doing so, I am getting cell
values, but I would like to get all formulas and formatting from the
source worksheets. Can anyone help.
Option Explicit
Sub MergeWorksheets()
Dim wrk As Workbook 'Workbook object - Always good to work with
object variables
Dim sht As Worksheet 'Object for handling worksheets in loop
Dim mst As Worksheet 'Master Worksheet
Dim rng As Range 'Range object
Dim colCount As Integer 'Column count in tables in the worksheets
Set wrk = ActiveWorkbook 'Working in active workbook
For Each sht In wrk.Worksheets
If sht.Name = "All Accounts-Details" Then
MsgBox "There is a worksheet called 'All Accounts-
Details'." & vbCrLf & _
"Please remove or rename this worksheet since this
is" & _
"the name of the result worksheet of this
process.", vbOKOnly + vbExclamation, "Error"
Exit Sub
End If
Next sht
'Deactivate Screen Updating
Application.ScreenUpdating = False
'Add new worksheet as the first worksheet
Set mst = wrk.Worksheets.Add(after:=wrk.Worksheets(14))
'Rename the new worksheet
mst.Name = "All Accounts-Details"
'Get column headers from the second worksheet
'Column count first
Set sht = wrk.Worksheets(2)
colCount = sht.Cells(1, 255).End(xlToLeft).Column
'Retrieve headers, no copy & paste needed
With mst.Cells(1, 1).Resize(1, colCount)
.Value = sht.Cells(1, 1).Resize(1, colCount).Value
'Set font as bold
.Font.Bold = True
End With
'Start loop
For Each sht In wrk.Worksheets
'If worksheet in loop is the last one, stop execution
If sht.Index = wrk.Worksheets.Count Then
Exit For
End If
If sht.Name <> Sheet9.Name Then
If sht.Visible = xlSheetVisible Then
' copy the data
Set rng = sht.Range(sht.Cells(2, 1), sht.Cells(65536, 1).End
(xlUp).Offset(-1).Resize(, colCount))
mst.Cells(65536, 1).End(xlUp).Offset(1).Resize(rng.Rows.Count,
rng.Columns.Count).Value = rng.Value
End If
End If
Next
'Fit the columns in Master worksheet
mst.Columns.AutoFit
' Columns("A:A").Select
Selection.AutoFilter
Selection.AutoFilter Field:=1, Criteria1:="<>0"
'Activate Screen Updating
Application.ScreenUpdating = True
wrk.Worksheets(3).Select
Range("A1:BJ1").Select
Selection.Copy
ActiveWindow.ScrollWorkbookTabs Position:=xlLast
Sheets("All Accounts-Details").Select
Range("A1:BJ1").Select
Selection.PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone,
_
SkipBlanks:=False, Transpose:=False
Selection.PasteSpecial Paste:=xlPasteColumnWidths,
Operation:=xlNone, _
SkipBlanks:=False, Transpose:=False
Sheets("All Accounts-Details").Select
Columns("F:F").Select
Application.CutCopyMode = False
Selection.NumberFormat = "@"
Cells(1, 1).Select
Sheets("All Accounts-Details").Select
Sheets("All Accounts-Details").Move Before:=Sheets(2)
End Sub
worksheets into one worksheet. When doing so, I am getting cell
values, but I would like to get all formulas and formatting from the
source worksheets. Can anyone help.
Option Explicit
Sub MergeWorksheets()
Dim wrk As Workbook 'Workbook object - Always good to work with
object variables
Dim sht As Worksheet 'Object for handling worksheets in loop
Dim mst As Worksheet 'Master Worksheet
Dim rng As Range 'Range object
Dim colCount As Integer 'Column count in tables in the worksheets
Set wrk = ActiveWorkbook 'Working in active workbook
For Each sht In wrk.Worksheets
If sht.Name = "All Accounts-Details" Then
MsgBox "There is a worksheet called 'All Accounts-
Details'." & vbCrLf & _
"Please remove or rename this worksheet since this
is" & _
"the name of the result worksheet of this
process.", vbOKOnly + vbExclamation, "Error"
Exit Sub
End If
Next sht
'Deactivate Screen Updating
Application.ScreenUpdating = False
'Add new worksheet as the first worksheet
Set mst = wrk.Worksheets.Add(after:=wrk.Worksheets(14))
'Rename the new worksheet
mst.Name = "All Accounts-Details"
'Get column headers from the second worksheet
'Column count first
Set sht = wrk.Worksheets(2)
colCount = sht.Cells(1, 255).End(xlToLeft).Column
'Retrieve headers, no copy & paste needed
With mst.Cells(1, 1).Resize(1, colCount)
.Value = sht.Cells(1, 1).Resize(1, colCount).Value
'Set font as bold
.Font.Bold = True
End With
'Start loop
For Each sht In wrk.Worksheets
'If worksheet in loop is the last one, stop execution
If sht.Index = wrk.Worksheets.Count Then
Exit For
End If
If sht.Name <> Sheet9.Name Then
If sht.Visible = xlSheetVisible Then
' copy the data
Set rng = sht.Range(sht.Cells(2, 1), sht.Cells(65536, 1).End
(xlUp).Offset(-1).Resize(, colCount))
mst.Cells(65536, 1).End(xlUp).Offset(1).Resize(rng.Rows.Count,
rng.Columns.Count).Value = rng.Value
End If
End If
Next
'Fit the columns in Master worksheet
mst.Columns.AutoFit
' Columns("A:A").Select
Selection.AutoFilter
Selection.AutoFilter Field:=1, Criteria1:="<>0"
'Activate Screen Updating
Application.ScreenUpdating = True
wrk.Worksheets(3).Select
Range("A1:BJ1").Select
Selection.Copy
ActiveWindow.ScrollWorkbookTabs Position:=xlLast
Sheets("All Accounts-Details").Select
Range("A1:BJ1").Select
Selection.PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone,
_
SkipBlanks:=False, Transpose:=False
Selection.PasteSpecial Paste:=xlPasteColumnWidths,
Operation:=xlNone, _
SkipBlanks:=False, Transpose:=False
Sheets("All Accounts-Details").Select
Columns("F:F").Select
Application.CutCopyMode = False
Selection.NumberFormat = "@"
Cells(1, 1).Select
Sheets("All Accounts-Details").Select
Sheets("All Accounts-Details").Move Before:=Sheets(2)
End Sub