부품

오늘도 문제 상황이 발생한 질문이 올라오고 다양한 해결법이 보입니다.
저는 논리력이 부족한 지 함수 특히 배열함수는 어떻게해서 사용해 볼려고 해도
불편해서?(사실 이해가 되질 않아서 ㅠㅠ) 사용하기가 꺼려지더군요.

특히나 여러 함수들을 자유자재로 응용해서 사용하시는 분들을 보면 부럽습니다.
댓글에 여러 해결법들이 있으니 잘 응용해서 사용하시면 실력이 늘 것입니다.

http://www.clien.net/cs2/bbs/board.php?bo_table=kin&wr_id=3674001

서브루틴 자체에 설명을 해 놓았고 변수도 되도록 이해하기 쉽게 정의해 두었으니
천천히 읽어보시면 다 이해되실 것으로 보입니다. 이것 이해하면 왠만한 비교 추출은
다 사용하실 수 있을 것입니다.

Option Explicit

Sub Calc_Parts_By_Plan()

Dim i As Integer, k As Integer
Dim cnt As Integer, ssum As Integer

Dim rngT As Range, rngTgt As Range
Dim rngR As Range, rngRef As Range
Dim rngU As Range, rngUniq As Range

Dim tgt As Worksheet, sht As Worksheet

‘ 경고 메시지 금지 및 속도를 위해 업데이트 중지
Application.DisplayAlerts = False
Application.ScreenUpdating = False

‘ 추출해서 붙여넣기할 데이터 시트가 기존에 있으면 삭제
For Each tgt In Worksheets
If tgt.Name = “ExtData” Then
tgt.Delete

End If
Next tgt

Set sht = Sheets(“PPlan”)

‘ 새 시트를 워크시트 제일 마지막에 ExtData라는 이름으로 추가
Set tgt = Worksheets.Add(after:=Worksheets(Worksheets.Count))
tgt.Name = “ExtData”

‘ 추출할 데이터 영역과 추출할 참조 영역 설정
Set rngTgt = Worksheets(“PPlan”).Range(“A:A”).SpecialCells(xlTextValues)
Set rngRef = Worksheets(“Parts”).Range(“A:A”).SpecialCells(xlTextValues)

‘ 제목행 삽입을 위해 데이터 위치 조정 및 제목행 삽입과 컬러링
cnt = 1

tgt.Cells(1, 1) = “Model”
tgt.Cells(1, 2) = “Parts”

With tgt.Cells(1, 3).Resize(1, 12)
.Value = sht.Cells(1, 2).Resize(1, 13).Value

.Font.Bold = True
.Interior.Color = &H80C0FF
End With

Set sht = Nothing

‘ 두 영역을 순환하면서 같은 데이터가 있으면 추출 시트에 복사
For Each rngT In rngTgt
For Each rngR In rngRef
If rngT = rngR Then

tgt.Range(“A1”).Offset(cnt, 0).Value = rngR.Offset(0, 0).Value
tgt.Range(“A1”).Offset(cnt, 1).Value = rngR.Offset(0, 1).Value

For i = 0 To 11
tgt.Range(“A1”).Offset(cnt, i + 2).Value = rngR.Offset(0, 2).Value2 * rngT.Offset(0, i + 1).Value2

Next i

cnt = cnt + 1

End If
Next rngR
Next rngT

Set rngTgt = Nothing
Set rngRef = Nothing

‘ 총합계산을 위해 출력할 위치 리셋
cnt = 0

Set sht = Sheets(“ExtData”)

‘ 중복항목을 제거하여 특정 위치에 목록 출력
Call UniqItemRng(Range(“B2”, Range(“B2”).End(xlDown)), Range(“P2”))

Set rngRef = Worksheets(“ExtData”).Range(“B2”, Range(“B2”).End(xlDown)).SpecialCells(xlTextValues)
Set rngUniq = Worksheets(“ExtData”).Range(“P2”, Range(“P2”).End(xlDown)).SpecialCells(xlTextValues)

For k = 1 To 12
For Each rngU In rngUniq
For Each rngR In rngRef

If rngU = rngR Then

ssum = ssum + rngR.Offset(0, k).Value2
tgt.Range(“P2”).Offset(cnt, k).Value = ssum

End If

Next rngR

cnt = cnt + 1
ssum = 0

Next rngU

cnt = 0

Next k

‘ 제목행 삽입
With tgt.Cells(1, 16).Resize(1, 13)
.Value = sht.Cells(1, 2).Resize(1, 15).Value

.Font.Bold = True
.Interior.Color = &H80C0FF
End With

‘ 보기 좋게 자동 칼럼 맞춤
tgt.Columns.AutoFit

‘ 경고 메시지 및 업데이트 갱신
Application.DisplayAlerts = True
Application.ScreenUpdating = True

End Sub

‘ 영역에서 중복 항목 제거해서 지정 위치에 세로로 출력
Sub UniqItemRng(SelRng As Range, TgtRng As Range)

Dim AllCells As Range, Cell As Range
Dim NoDupes As New Collection

Dim i As Integer, j As Integer, k As Integer
Dim Swap1, Swap2, item

Set AllCells = SelRng

On Error Resume Next

For Each Cell In AllCells

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

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

TgtRng.Offset(k, 0).Value = item

k = k + 1

Next item

Set Cell = Nothing
Set AllCells = Nothing

End Sub

첨부화일 : 20160310-부품 소요량 분석