무른모

보통 일간 주문현황이나 생산현황 등 일간 보고서를 양식으로 만들고 각 시트마다 자료를 정리하고
월간이나 분기, 반기, 년간 별로 보고 자료를 작성해야하는 경우 그 자료를 취합하기가 만만찮은
작업입니다. 일간 자료를 시트마다 전체 복사해서 한 시트에 모으는 것도 장난?아닌데 년간 자료를
만드는 것은 상상하기도 힘든 작업입니다. (물론 일간이 모여 월간자료가 생성되면 조금은 덜하지만)

http://www.clien.net/cs2/bbs/board.php?bo_table=kin&wr_id=3523876
(엑셀 – 여러 시트에서 특정 값이 들어있는 행 가져오기)

며칠간 도저히 버그를 잡지 못해 일단 올리고 봅니다. 루프가 돌기는 도는데 계속 클릭을 하는 순서에
따라 순차적으로 검색이 되고 안되기를 하는데 원인을 찾지를 못해서 사용은 할 수 있을 것 같아서
일단 올리고 버그는 더 잘아시는 분이 코드에서 찾아서 댓글로 올려 주세요. …

ps> 버그 잡았습니다. … 역시 벌레는 찾는 곳이 아닌 다른 곳에 숨어 있었군요.

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

sht.Delete

Exit Sub
End If
Next sht

위의 삭제 시트 코드와 저 아래의 시트 삭제 코드에서 Exit Sub를 주석처리하면 됩니다.

루틴을 돌려보니 한 번은 되고 한 번은 안되고 하는 이유가 보이네요. 시트가 없으면 실행되고

시트가 있으면 시트 삭제하고 Sub를 마쳐버려서 그렇네요.

유저폼의 리스트를 클릭하면 하나는 되고 그다음 클릭은 되지 않고 아무거나 눌러서 가짜 클릭을?
만들고 원하는 리스트를 클릭하면 자료가 만들어지는 순환구조상으로는 아무 문제가 없는데?
문제가 나타나는 기이한 버그?입니다. 여러 방법으로 처리를 해 보았는데 똑같은 결과가 나오는
것으로 보아 해당 코드에 버그가 있는데 도저히 보이지를 않습니다. 아래 코드입니다.

Do While Range(“START”).Offset(i, 1) <> “”
If Left(Range(“START”).Offset(i, 2), InStr(Range(“START”).Offset(i, 2), “-“) – 1) = FindStr
Then
Range(Range(“START”).Offset(i, 0), Range(“START”).Offset(i, 17)).Copy

intCount = intCount + 1

trg.Range(“A1”).Offset(intCount, 0).Select
trg.Paste

End If

i = i + 1
Loop

우선 워크시트를 통합하는 코드와 폴더(디렉토리)에 모여있는 모든 엑셀 화일을 통합하는코드입니다.

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

Exit Sub
End If
Next sht

Application.DisplayAlerts = True
Application.ScreenUpdating = False

Set trg = wrk.Worksheets.Add(after:=wrk.Worksheets(wrk.Worksheets.Count))
trg.Name = “Master”
Set sht = wrk.Worksheets(1)
colCount = sht.Cells(1, 255).End(xlToLeft).Column

With trg.Cells(1, 1).Resize(1, colCount)
.Value = sht.Cells(1, 1).Resize(1, colCount).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(2, 1), sht.Cells(65536, 1).End(xlUp).Resize(, colCount))

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

Next sht

trg.Activate

Range(“A2″).Select
ActiveWorkbook.Names.Add Name:=”START”, RefersToR1C1:=”=Master!R2C1″

trg.Columns.AutoFit

Call ExtUniqItemRng(UserForm1.ListBox1)

UserForm1.Show

Application.ScreenUpdating = True

End Sub
통합된 자료에서 추출하고자 하는 문자열을 구하는 루틴입니다. 제 팁에서 자주 사용되고 있는 루틴을
변형하여 특정 값에서 문자를 추출하고 그 추출된 문자열의 중복 항목을 제거하여 사용자폼의 리스트에
정렬하는 방법입니다. VBA에서 Userform을 하나 만드시고 Listbox하나를 만들어 Object로 넘기는
소스입니다.

Sub ExtUniqItemRng(obj As Object)

Dim TempStr As String

Dim intNum As Integer
Dim NumCnt As Integer

Dim Cell As Range
Dim NoDupes As New Collection

Dim i As Integer, j As Integer
Dim Swap1, Swap2, item
Dim UniqStr As String

Dim TgtCel As Range
Dim SelRng As Range

Set SelRng = Range(“C2”, Range(“C2”).End(xlDown))

Application.ScreenUpdating = False

On Error Resume Next

For Each Cell In SelRng

If Len(Cell.Value) > 0 Then ‘ 빈셀을 포함시키지 않음
‘ Add method의 2번째 인자는 문자열이어야만 함
NoDupes.Add Left(Cell.Value, InStr(Cell.Value, “-“) – 1), Left(CStr(Cell.Value), InStr(CStr
(Cell.Value), “-“) – 1)

End If

Next Cell

On Error GoTo 0

For i = 1 To NoDupes.Count – 1

For j = i + 1 To NoDupes.Count

If NoDupes(i) > NoDupes(j) Then

Swap1 = NoDupes(i)
Swap2 = NoDupes(j)

NoDupes.Add Swap1, before:=j
NoDupes.Add Swap2, before:=i
NoDupes.Remove i + 1
NoDupes.Remove j + 1

End If

Next j

Next i

For Each item In NoDupes

obj.AddItem item

Next item

Set Cell = Nothing

Application.ScreenUpdating = True

End Sub
Userform의 Listbox의 Listitem을 클릭할 때마다 List내용을 받아서 자료를 추출하는 소스입니다.

Sub ExtItemSelect(FindStr As String)

Dim i As Integer, cnt As Integer
Dim colCount As Integer, intCount As Integer
Dim wrk As Workbook

Dim sht As Worksheet
Dim trg As Worksheet

Dim Ccel As Range
Dim SelRng As Range

Set wrk = ActiveWorkbook

Application.DisplayAlerts = False

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

sht.Delete

Exit Sub
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)
colCount = sht.Cells(1, 255).End(xlToLeft).Column

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

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

Do While Range(“START”).Offset(i, 1) <> “”
If Left(Range(“START”).Offset(i, 2), InStr(Range(“START”).Offset(i, 2), “-“) – 1) = FindStr
Then
Range(Range(“START”).Offset(i, 0), Range(“START”).Offset(i, 17)).Copy

intCount = intCount + 1

trg.Range(“A1”).Offset(intCount, 0).Select
trg.Paste

End If

i = i + 1
Loop
Application.ScreenUpdating = True

Columns.AutoFit

End Sub
순환 논리는 맞는데 아무리 봐도 추출되지 않는 원인이 보이지 않으니 답답하지만
누가 잘 해결해 주실거라고 믿고 팁란에 올립니다.

첨부 화일 : 20150908-시트 통합, 월간년간보고서 작성 및 특정 자료 추출 보고