Previously i was working for some of my projects and got a problem to solve. Here i have providing a Visual Basic script which will help you to merge lots of excel sheets it to one sheet (MasterSheet).
The code below will sequentially merge all existing worksheets (except the first) into the first worksheet.
Sub MergeSheets()
Const rRANGE = "A1: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 (rRANGE).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
Place the code in ThisWorkbook and use Tools > Macro > Macros > Run to execute it or use Tools > Macro > Macros > Options to assign a shortcut for frequent use.
The code below will sequentially merge all existing worksheets (except the first) into the first worksheet.
Sub MergeSheets()
Const rRANGE = "A1: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 (rRANGE).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
Place the code in ThisWorkbook and use Tools > Macro > Macros > Run to execute it or use Tools > Macro > Macros > Options to assign a shortcut for frequent use.
0 comments:
Post a Comment
Thanks For Your Valuable Time.