Sub MergeSheetsOutHead()
'시트 병합 : 머릿글 빼고 현재 워크북의 전체 시트 병합
'머릿글의 첫번째 열에 해당하는 값이 1행과 2행을 병합한 셀에 있는 경우 병합 안됨
'리본메뉴 이식시 작동 안됨..??
Dim startRow, startCol, lastRow, lastCol As Long
Dim headers As Range
Dim HeadFirstRow As Integer
Dim HeadLastRow As Integer
Dim HeadFirstColumn As Integer
Dim HeadLastColumn As Integer
Application.DisplayAlerts = False
Application.ScreenUpdating = False
Set wb = ThisWorkbook
'Get Headers
On Error GoTo ExitHandler
Set headers = Application.InputBox("표의 제목 줄을 1회만 포함하여 시트 병합을 진행합니다." & Chr(13) & Chr(13) & "★ 현재 파일의 모든 시트는 동일한 형식을 갖추어야 합니다. ★" & Chr(13) & Chr(13) & "표의 제목 줄을 선택하세요(통합시 한번만 카피 됩니다.) " & Chr(13) & Chr(13) & "★ 제목 줄에 복수의 행이 병합 된 셀이 있는 경우 오류 발생합니다. ★" & Chr(13) & Chr(13) & "★ 제목 줄에 복수의 행이 병합 된 셀이 있는 경우 분할 후 진행★" & Chr(13) & Chr(13) & "시트를 병합하시려면 제목 줄의 범위를 지정해주세요", Type:=8)
On Error GoTo ExitHandler
'======헤더 위치 값=========
HeadFirstRow = headers.Row
'MsgBox ("first row " & nFirstRow)
HeadLastRow = headers.Rows.Count + headers.Row - 1
'MsgBox ("last row " & nLastRow)
HeadFirstColumn = headersColumn
'MsgBox ("first column " & nFirstColumn)
HeadLastColumn = headers.Columns.Count + headers.Column - 1
'MsgBox ("last column " & nLastColumn)
'======헤더 위치 값=========
On Error Resume Next
Sheets("Master").Delete
On Error Resume Next
Sheets.Add.Name = "Master"
On Error Resume Next
'Set Master sheet for cosolidation
Set mtr = Worksheets("Master")
headers.Copy mtr.Range("A1")
'startRow = headers.Row + 1
startRow = HeadLastRow + 1
startCol = headers.Column
Debug.Print "시작행 : "; startRow, "시작열 : "; startCol, "제목시작행 : "; HeadFirstRow, "제목끝행 : "; HeadLastRow
'loop through all sheets
For Each ws In wb.Worksheets
'except the master sheet from looping
If ws.Name <> "Master" Then
ws.Activate
lastRow = Cells(Rows.Count, startCol).End(xlUp).Row
lastCol = Cells(startRow, Columns.Count).End(xlToLeft).Column
'get data from each worksheet and copy it into Master sheet
Range(Cells(startRow, startCol), Cells(lastRow, lastCol)).Copy _
mtr.Range("A" & mtr.Cells(Rows.Count, 1).End(xlUp).Row + 1)
End If
Next ws
Worksheets("Master").Activate
Application.DisplayAlerts = True
Application.ScreenUpdating = True
ExitHandler:
Application.DisplayAlerts = True
Application.ScreenUpdating = True
Exit Sub
End Sub
from : https://www.exceltip.com/cells-ranges-rows-and-columns-in-vba/consolidatemerge-multiple-worksheets-into-one-master-sheet-using-vba.html
