Tip

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

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-시트 통합, 월간년간보고서 작성 및 특정 자료 추출 보고

목감기에 걸려 코가 간질간질한데 재채기가 나올려고만 하고 정작 나오지 않는 것처럼
아래 질문은 이해가 되긴 되는데 뭔가 부족하여 전체를 수작업 비슷하게 해야될 것 같아
우선 해결 논리를 세울려고 고민에 고민을 거듭하였습니다.

http://www.clien.net/cs2/bbs/board.php?bo_table=kin&wr_id=3517736
(엑셀 함수 질문드립니다.(매칭관련)

질문의 내용을 보면 어떤 형식은 있는데 정규화 시킬 방법을 찾기가 너무 힘들었습니다.
댓글의 내용을 보면 어느 정도 정규화 시킬 수 있을 것 같은데 코는 간질 간질 하는데
재채기가 나올 생각을 하지 않는 것처럼 마음은 답답한데 실마리는 보이지 않았습니다.

<댓글>
달린 순서는 상관없습니다.
——
OXXX
OOXX
OXOX
OXXO
OOOX
OOXO
OXOO
OOOO
XOXX
XOOX
XOXO
XOOO
XXOX
XXOO
XXXO
(일단 복사하고 – 엑셀상에서 다시 선택해서 복사
선택하여붙여넣기-행열바꿔서 식으로 하면 됩니다.)
…
</댓글>

. 고민 중
. 고민 중
. 고민 중

!!!

위 코드를 정렬시켜 봅니다. 그리고 행렬 바꿔 복사해서 보면 이렇게 됩니다.
(한 행에 걸쳐 있는데 이 본문을 보기좋게 하기위하여 줄바꿈했습니다.)
XXXO XXOX  XXOO  XOXX  XOXO  XOOX  XOOO
OXXX  OXXO  OXOX  OXOO  OOXX  OOXO  OOOX  OOOO

뭔가 규칙 아닌 규칙이 보입니다. 잘 보세요. 서로 다른 숫자를 X라 하고 같은 숫자를 O라 할 때
이 X를 0(Zero)로 O를 1로 치환을 해 봅시다. 그러면 아래와 같은 정렬로 됩니다. 뭔가 보이나요?
0001 0010 0011 0100 0101 0110 0111
1000 1001 1010 1011 1100 1101 1110 1111

일단은 어떻게든 숫자로 처리할 수 있을 것 같습니다. 그렇습니다. 컴퓨터는 좋아하고 우리들은
싫어하는? 이진수가 보이네요. 이제 우리의 아이디어가 들어갈 순서입니다. 이진수를 십진수로
바꾸어 주는 함수입니다. (제가 만든 것은 아니고 구걸했습니다. ^^;;;)

Function BinToDec(Bin As String) As Long

Dim i As Integer

For i = 1 To Len(Bin)
BinToDec = BinToDec * 2 + CInt(Mid(Bin, i, 1))

Next

End Function

이제 이 함수의 인자로 저 규칙을 전달하면 아래와 같은 정수를 얻습니다.
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15

이제 조건식을 만들고 그 위치에 찾아진 값들을 특정 셀에 뿌려주면 됩니다. 사실 코드를 생각하는
시간이 무지 많이 들었고 그 조건식을 비교하는 루틴에서 아래 설명에 있겠지만 조건을 비교하는
순서를 잘못해서 기준값이라는 개념없이 접근해서 오류가 많이 났습니다.

Option Explicit

Sub Kind_Count()

Dim rcnt As Integer
‘ 순환, 참조할 영역
Dim Cel As Range
Dim RefCel As Range

Dim RngCel As Range
Dim RngRef As Range

‘ 찾을 값들의 최초 참조 영역
Set RngCel = Range(“A4”, Range(“A4”).End(xlDown))

‘ 참조할 값
Set RngRef = Range(“E1:S1”)
‘ 속도를 위해 업데이트 하지 않고 계산
Application.ScreenUpdating = False

‘ 전체 행의 수를 확인하여 자동화 가능
rcnt = Range(“A4”).End(xlDown)
Range(“E4:S” & rcnt).ClearContents

‘ 참조 영역 순환
For Each Cel In RngCel
‘ 참조할 값 순환
For Each RefCel In RngRef

‘ 몇 번의 시행착오를 거치면서 참조할 위치를 선정하는 것이 중요함
‘ 즉 참조할 “1” 혹은 “O”의 위치를 기준으로 같다, 다르다를 설정해야 에러가 나지 않음
‘ 이 구문에서 무지 헤메임

Select Case RefCel.Value
‘ 1과 같다는 것은 4번째 행의 숫자가 전체와 다 다르다는 것을 의미함
‘ 즉 “1”과 “O”의 위치임
Case 1
If Cel.Offset(0, 3).Value <> Cel.Offset(0, 0).Value And Cel.Offset(0, 3).Value <>
Cel.Offset(0, 1).Value And Cel.Offset(0, 3).Value <> Cel.Offset(0, 2).Value Then
Cel.Offset(0, 3 + RefCel.Value).Value = Cel.Offset(0, 3).Value

End If

Case 2
If Cel.Offset(0, 2).Value <> Cel.Offset(0, 0).Value And Cel.Offset(0, 2).Value <>
Cel.Offset(0, 1).Value And Cel.Offset(0, 2).Value <> Cel.Offset(0, 3).Value Then
Cel.Offset(0, 3 + RefCel.Value).Value = Cel.Offset(0, 2).Value

End If

Case 3
If Cel.Offset(0, 2).Value <> Cel.Offset(0, 0).Value And Cel.Offset(0, 3).Value <>
Cel.Offset(0, 1).Value And Cel.Offset(0, 3).Value = Cel.Offset(0, 2).Value Then
Cel.Offset(0, 3 + RefCel.Value).Value = Cel.Offset(0, 2).Value

End If

Case 4
If Cel.Offset(0, 1).Value <> Cel.Offset(0, 0).Value And Cel.Offset(0, 1).Value <>
Cel.Offset(0, 2).Value And Cel.Offset(0, 1).Value <> Cel.Offset(0, 3).Value Then
Cel.Offset(0, 3 + RefCel.Value).Value = Cel.Offset(0, 1).Value

End If

Case 5
If Cel.Offset(0, 1).Value = Cel.Offset(0, 3).Value And Cel.Offset(0, 3).Value <>
Cel.Offset(0, 0).Value And Cel.Offset(0, 3).Value <> Cel.Offset(0, 2).Value Then
Cel.Offset(0, 3 + RefCel.Value).Value = Cel.Offset(0, 1).Value

End If

Case 6
If Cel.Offset(0, 1).Value = Cel.Offset(0, 2).Value And Cel.Offset(0, 1).Value <>
Cel.Offset(0, 0).Value And Cel.Offset(0, 1).Value <> Cel.Offset(0, 3).Value Then
Cel.Offset(0, 3 + RefCel.Value).Value = Cel.Offset(0, 1).Value

End If

Case 7
If Cel.Offset(0, 1).Value <> Cel.Offset(0, 0).Value And Cel.Offset(0, 1).Value =
Cel.Offset(0, 2).Value And Cel.Offset(0, 1).Value = Cel.Offset(0, 3).Value Then
Cel.Offset(0, 3 + RefCel.Value).Value = Cel.Offset(0, 1).Value

End If

Case 8
If Cel.Offset(0, 0).Value <> Cel.Offset(0, 3).Value And Cel.Offset(0, 0).Value <>
Cel.Offset(0, 1).Value And Cel.Offset(0, 0).Value <> Cel.Offset(0, 2).Value Then
Cel.Offset(0, 3 + RefCel.Value).Value = Cel.Offset(0, 0).Value

End If

Case 9
If Cel.Offset(0, 0).Value = Cel.Offset(0, 3).Value And Cel.Offset(0, 0).Value <>
Cel.Offset(0, 1).Value And Cel.Offset(0, 0).Value <> Cel.Offset(0, 2).Value Then
Cel.Offset(0, 3 + RefCel.Value).Value = Cel.Offset(0, 0).Value

End If

Case 10
If Cel.Offset(0, 0).Value = Cel.Offset(0, 2).Value And Cel.Offset(0, 0).Value <>
Cel.Offset(0, 1).Value And Cel.Offset(0, 0).Value <> Cel.Offset(0, 3).Value Then
Cel.Offset(0, 3 + RefCel.Value).Value = Cel.Offset(0, 0).Value

End If

Case 11
If Cel.Offset(0, 0).Value = Cel.Offset(0, 3).Value And Cel.Offset(0, 0).Value =
Cel.Offset(0, 2).Value And Cel.Offset(0, 0).Value <> Cel.Offset(0, 1).Value Then
Cel.Offset(0, 3 + RefCel.Value).Value = Cel.Offset(0, 0).Value

End If

Case 12
If Cel.Offset(0, 0).Value = Cel.Offset(0, 1).Value And Cel.Offset(0, 0).Value <>
Cel.Offset(0, 2).Value And Cel.Offset(0, 0).Value <> Cel.Offset(0, 3).Value Then
Cel.Offset(0, 3 + RefCel.Value).Value = Cel.Offset(0, 0).Value

End If

Case 13
If Cel.Offset(0, 0).Value = Cel.Offset(0, 1).Value And Cel.Offset(0, 2).Value <>
Cel.Offset(0, 0).Value And Cel.Offset(0, 3).Value = Cel.Offset(0, 0).Value Then
Cel.Offset(0, 3 + RefCel.Value).Value = Cel.Offset(0, 0).Value

End If

Case 14
If Cel.Offset(0, 0).Value <> Cel.Offset(0, 3).Value And Cel.Offset(0, 0).Value =
Cel.Offset(0, 1).Value And Cel.Offset(0, 0).Value = Cel.Offset(0, 2).Value Then
Cel.Offset(0, 3 + RefCel.Value).Value = Cel.Offset(0, 0).Value

End If

‘ …. “15”라는 숫자는 이진수로 하면 “1111”과 같으므로 전체 숫자가 동일하다는 것을
의미함
Case 15
If Cel.Offset(0, 0).Value = Cel.Offset(0, 3).Value And Cel.Offset(0, 0).Value =
Cel.Offset(0, 1).Value And Cel.Offset(0, 0).Value = Cel.Offset(0, 2).Value Then
Cel.Offset(0, 3 + RefCel.Value).Value = Cel.Offset(0, 0).Value

End If

End Select

Next

Next

‘ 업데이트 진행
Application.ScreenUpdating = True

End Sub

‘ 십진수를 이진수로 만드는 함수
Function DecToBin(Dec As Long) As String

Do
DecToBin = CStr(Dec Mod 2) & DecToBin
Dec = Dec \ 2

Loop Until Dec = 0

End Function

‘ 이진수를 십진수로 만드는 함수
Function BinToDec(Bin As String) As Long

Dim i As Integer

For i = 1 To Len(Bin)
BinToDec = BinToDec * 2 + CInt(Mid(Bin, i, 1))

Next

End Function
그리고 마지막 행에 중복 위치별로 숫자의 카운트를 하거나 해당 숫자의 갯수를
세거나 하는 등의 함수를 추가하여 가공이 가능합니다.

첨부 화일 : 20150831-행별 중복 유형별 해당 숫자 추출

이제 지금 지나가는 태풍이 끝나고 나면 가을걷이가 한창일 것입니다.
더운 여름 잠시 우리들은 일상을 떠나 휴가를 가서 지친 심신을 달래는데
휴가지의 민박집이나 펜션들은 손님 맞이에 정신이 없었을 것입니다.

휴가지에 숙박을 예약하려면 담당 직원들이 그 숙박지의 예약 상태를 알아야
적절히 룸을 운영하여 예약 잘못으로 인해 모처럼의 휴가를 망치지 않을 것입니다.
어떤 분이 홈페이지를 운영하기 전에 임시로 엑셀로 예약상황을 관리하시겠다고
질문을 올려주셨는데 그 해답?을 간단한 팁으로 올립니다.

http://www.clien.net/cs2/bbs/board.php?bo_table=kin&wr_id=3505287
(엑셀 날짜 작업 문의)

Option Explicit

Sub Count_Persons_In_Rooms()

Dim cnt As Integer
Dim Indate As Date
Dim RngCel As Range

Dim sht As Worksheet

‘ 검색된 자료를 출력할 위치를 구함
cnt = 1

‘ 검색된 자료를 출력할 시트를 생성, 있으면 경고없이 삭제
Application.DisplayAlerts = False

For Each sht In Worksheets
If sht.Name = “Persons_In_Rooms” Then
sht.Delete

End If
Next sht

‘ 검색된 자료를 출력하기 위한 시트 생성
Worksheets.Add(After:=Sheets(Sheets.Count)).Name = “Persons_In_Rooms”

Set sht = Sheets(“Persons_In_Rooms”)

Sheets(“sheet1”).Select

‘ 같은 시트에 출력할 때 아래 코멘트를 지우고 사용하면 됨
‘ Range(“G2”, Range(“H2”).End(xlDown)).ClearContents

Indate = Cells(1, 6).Value

For Each RngCel In Range(“B2”, Range(“B65536”).End(xlUp))

If Indate >= RngCel.Value Then
‘ check out 날짜는 그날을 포함할지 안할지는 결정(<, <=)
If Indate <= RngCel.Offset(0, 1).Value Then

cnt = cnt + 1

‘ 새 시트에 자료 생성
sht.Range(“A1”).Value = “일자”
sht.Range(“B1”).Value = “호실”
sht.Range(“C1”).Value = “인원”

Range(“F1”).Copy sht.Range(“A” & cnt)
RngCel.Offset(0, 2).Copy sht.Range(“A” & cnt).Offset(0, 1)
RngCel.Offset(0, 3).Copy sht.Range(“A” & cnt).Offset(0, 2)

‘ 같은 시트에 자료 출력할 때는 위의 6줄에 코멘트를 지우고 아래 코드를 사용
‘ Range(“G” & cnt).Value = RngCel.Offset(0, 2).Value
‘ Range(“G” & cnt).Offset(0, 1).Value = RngCel.Offset(0, 3).Value

End If
End If

Next

Application.DisplayAlerts = True

Sheets(“Persons_In_Rooms”).Select

End Sub

그냥 간단하게 출력하는 루틴을 만들었는데 특정 영역을 지정하거나 동적이름을 정의해서
더 활용할 수 있음. 더 확장하면 특정일로 부터 체크아웃하는 날까지 일자별로 리스트를
만들어서 출력할 수도 있으나 간단한 팁으로 올리는 것이므로 응용해서 사용바랍니다.

첨부 화일 : 20150825-Persons_In_Rooms