EXCEL - code to merge sheets into one


Sub MergeSheets()
 Const sRANGE = "A2:Z100"
 Dim iSheet, iTargetRow As Long, oCell As Object, bRowWasNotBlank As Boolean
 Dim iTop, iLeft, iBottom, iRight As Long
 'Sheets(1).Select: Sheets.Add
 Sheets(1).Select
 Cells.Select
 Selection.Clear
 bRowWasNotBlank = True
 For iSheet = 2 To ThisWorkbook.Sheets.Count: DoEvents
 For Each oCell In Sheets(iSheet).Range(sRANGE).Cells: DoEvents
 If oCell.Column = 1 Then
 If bRowWasNotBlank Then iTargetRow = iTargetRow + 1
 bRowWasNotBlank = False
 End If
 If oCell.MergeCells Then
 bRowWasNotBlank = True
 If oCell.MergeArea.Cells(1).Row = oCell.Row Then
 If oCell.MergeArea.Cells(1).Column = oCell.Column Then
 Sheets(1).Cells(iTargetRow, oCell.Column) = oCell
 iTop = iTargetRow
 iLeft = oCell.Column
 iBottom = iTop + oCell.MergeArea.Rows.Count - 1
 iRight = iLeft + oCell.MergeArea.Columns.Count - 1
 Sheets(1).Range(Cells(iTop, iLeft), Cells(iBottom, iRight)).MergeCells = True
 End If
 End If
 End If
 If Len(oCell) Then bRowWasNotBlank = True
 Sheets(1).Cells(iTargetRow, oCell.Column) = oCell
 Next oCell
 Next
 Sheets(1).Activate
 End Sub


No comments:

Post a Comment