|
* 답변하시는 분들께 도움이 되도록 자신의 환경을 아래 항목 옆에 기재해 주세요.
- 엑셀 버전(95,97,2000,xp,2003,2007):
* 아래줄에 질문을 작성하세요 >>
말로 설명이 어려워 파일 엑셀 파일 첨부하였습니다.
일일 데이터 입력 값에 대한 보고서 작성시 해당 조건에 맞는 데이터를 불러오고 싶습니다.
도와주세요
==============[감사해요님 글에 대한 답변입니다]==============
첨부화일 참고하세요...
Sub getFinalReport()
Dim wst As Worksheet
Dim rData As Range, rRow As Range
Dim rTg As Range, rTemp As Range
Dim iX As Integer, iCnt As Integer
Dim iRow As Integer, iCol As Integer
Dim datStart As Date, datEnd As Date
Dim oDic As Object, oDicSub As Object, oList As Object
Dim vKey, vItem, vSubKey, vSubItem
With Application
.ScreenUpdating = False
.EnableEvents = False
.Calculation = xlCalculationManual
End With
Set wst = Worksheets("Ans") ' 작업시트
Set rData = wst.Range("DataTable[#Data]") ' 입력 테이블에서 데이터만
Set rTg = wst.Range("AE10") ' 최종보고서 위치
Set rTemp = wst.Range("AX10") ' 임시작업 위치
datStart = wst.Range("F5") ' 기간 - 시작일
datEnd = wst.Range("G5") ' 종료일
' 최종보고서 기존자료 지우기
If rTg.CurrentRegion.Cells(rTg.CurrentRegion.Cells.Count).Row >= rTg.Row Then
Range(rTg, rTg.CurrentRegion.Cells(rTg.CurrentRegion.Cells.Count)).Clear
End If
Set oDic = CreateObject("Scripting.Dictionary")
For Each rRow In rData.Rows
If rRow.Cells(1, 2) >= datStart And rRow.Cells(1, 2) <= datEnd Then
vKey = rRow.Cells(1, 1) & vbTab & rRow.Cells(1, 4) & vbTab & rRow.Cells(1, 3)
vItem = rRow.Cells(1, 5)
oDic(vKey) = oDic(vKey) + vItem
End If
Next
' 임시작업 - 품종,구분별 Top 4을 찾기위한 작업
rTemp.CurrentRegion.Clear
For Each vKey In oDic.keys
iX = iX + 1
rTemp.Cells(iX, 1).Resize(1, 3) = Split(vKey, vbTab)
rTemp.Cells(iX, 4) = oDic(vKey)
Next
oDic.RemoveAll ' 재사용을 위해 자료 초기화
With rTemp.CurrentRegion
' 품종/구분은 오름차순, 수량은 내림차순으로 정렬
.Sort Key1:=.Cells(1, 1), Key2:=.Cells(1, 2), key3:=.Cells(1, 4), Order3:=xlDescending, Header:=xlNo
End With
For Each rRow In rTemp.CurrentRegion.Rows
vKey = rRow.Cells(1, 1)
vSubKey = rRow.Cells(1, 2)
vItem = rRow.Cells(1, 3).Resize(1, 2).Value
If oDic.Exists(vKey) Then
Set oDicSub = oDic(vKey)
If oDicSub.Exists(vSubKey) Then
If oDicSub(vSubKey).Count < 4 Then ' 수량합이 상위 4번째까지 값을 체크함
oDicSub(vSubKey).Add vItem
End If
Else
Set oList = CreateObject("System.Collections.ArrayList")
oList.Add vItem
oDicSub.Add vSubKey, oList
End If
Else
Set oDicSub = CreateObject("Scripting.Dictionary")
Set oList = CreateObject("System.Collections.ArrayList")
oList.Add vItem
oDicSub.Add vSubKey, oList
oDic.Add vKey, oDicSub
End If
Next
rTemp.CurrentRegion.Clear
iCnt = 1
For Each vKey In oDic.keys
iRow = iRow + iCnt
rTg.Cells(iRow, 1) = vKey
Set oDicSub = oDic(vKey)
iCnt = 1
For Each vSubKey In oDicSub.keys
Set oList = oDicSub(vSubKey)
iCol = 2 ' 가공열 위치
If vSubKey = "재료" Then iCol = 4 ' 재료열 위치
For iX = 0 To oList.Count - 1
rTg.Cells(iX + iRow, iCol).Resize(1, 2).Value = oList(iX)
Next
If iCnt < oList.Count Then iCnt = oList.Count
Next
With rTg.Cells(iRow, 1).Resize(iCnt, 5)
.HorizontalAlignment = xlCenter
.BorderAround LineStyle:=xlContinuous
.Offset(0, 1).Resize(, 4).Borders.LineStyle = xlContinuous
End With
Next
Set oDic = Nothing
Set oDicSub = Nothing
Set oList = Nothing
With Application
.ScreenUpdating = False
.EnableEvents = False
.Calculation = xlCalculationManual
End With
End Sub
|
|