추출

오랜만에 자료 올리네요. 기존에 내용이 있어서 쉽게 만들 수 있었네요.

Option Explicit

Sub MergeWBs()

Dim wbDst As Workbook
Dim wbSrc As Workbook

Dim wsSrc As Worksheet

Dim MyPath As String
Dim strFilename As String

Application.DisplayAlerts = False
Application.EnableEvents = False
Application.ScreenUpdating = False

MyPath = “C:\Data”

Set wbDst = ThisWorkbook

strFilename = Dir(MyPath & “\*.xls”, vbNormal)

If Len(strFilename) = 0 Then Exit Sub

Do Until strFilename = “”

Set wbSrc = Workbooks.Open(Filename:=MyPath & “\” & strFilename)

Set wsSrc = wbSrc.Worksheets(1)

wsSrc.Copy after:=wbDst.Worksheets(wbDst.Worksheets.Count)

wbSrc.Close False

strFilename = Dir()

Loop

wbDst.Worksheets(1).Delete

Application.DisplayAlerts = True
Application.EnableEvents = True
Application.ScreenUpdating = True

End Sub

Sub MergeWSs()

Dim wrk As Workbook

Dim sht As Worksheet
Dim trg As Worksheet

Dim rng As Range
Dim colCount As Integer

Set wrk = ActiveWorkbook

Application.DisplayAlerts = False

For Each sht In wrk.Worksheets
If sht.Name = “Master” Or sht.Name = “ExtData” Then

sht.Delete

End If
Next sht

Application.DisplayAlerts = True
Application.ScreenUpdating = False

Set trg = wrk.Worksheets.Add(after:=wrk.Worksheets(wrk.Worksheets.Count))
trg.Name = “ExtData”
Set sht = wrk.Worksheets(1)

With trg.Cells(1, 1).Resize(1, 3)
.Value = sht.Cells(1, 1).Resize(1, 3).Value

.Font.Bold = True
.Interior.Color = vbGreen
End With

For Each sht In wrk.Worksheets
If sht.Index = wrk.Worksheets.Count Then
Exit For
End If

Set rng = sht.Range(sht.Cells(31, 1), sht.Cells(31, 1).Resize(, 4))

trg.Cells(65536, 1).End(xlUp).Offset(1).Resize(rng.Rows.Count, 3).Value = rng.Value

Next sht

trg.Activate

trg.Columns.AutoFit

Application.ScreenUpdating = True

End Sub

차근 차근 읽어보시면 이해가 되실 것입니다.

첨부 : 20160217-각 워크북의 특정 시트의 특정열 병합