무른모

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

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

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-부품 소요량 분석

아질게 게시판에 엑셀 관련 조금 복잡한 질문의 내용들이 나오지 않아
심심하던 차에? 조금 복잡한 내용이 나왔네요.

http://www.clien.net/cs2/bbs/board.php?bo_table=kin&wr_id=3673755
하루종일 검색해보았지만 알 수 없었던 엑셀문제ㅠ 혹시 아시는 분 계실까요?

질문의 내용이 더 어려워 해석하느라 시간이 좀 걸렸습니다. 한 칼럼을 기준으로
같은 내용이 있으면 두 시트를 일정 방법으로 합쳐달라는 요지더군요.

간단히 VLOOKUP함수로 처리할 수도 있지만 저는 함수를 잘 활용하지 못하고
정형화된 내용은 VBA로 해결하는 사람이라 VBA로 짧은 코드 한번 짜 보았습니다.

Option Explicit

Sub Mergy_By_Same_Value()

Dim cnt As Integer, i As Integer

Dim rngCell As Range, rngTgt As Range
Dim rngR As Range, rngRef As Range

Dim tgt As Worksheet

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

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

End If
Next tgt

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

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

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

For Each rngR In rngRef

If rngCell = rngR Then
‘셀 병합하여 붙여넣을 위치 결정
For i = 0 To 6
tgt.Range(“A1”).Offset(cnt, i * 2).Value = rngCell.Offset(0, i – 6).Value
tgt.Range(“A1”).Offset(cnt, i * 2 + 1).Value = rngR.Offset(0, i – 6).Value

Next i

cnt = cnt + 1

Exit For

End If

Next rngR

Next rngCell

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

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

End Sub

참조 : 20160309-같은 셀값 참조하여 두 시트 합침