나눔터  
  HOME > 나눔터 > 묻고답하기 > 엑셀
엑셀
엑셀에 대한 질문과 답변을 올려주세요. 단, 취지에 맞지 않는 글은 운영자가 삭제합니다.
 "000 님, 도와주세요", "부탁 드립니다.", "급합니다!" 등과 같이 막연한 제목을 달지 말아주세요.
[필독] 빠르고 정확한 답변을 얻는 16가지 Tip !
[필독] 저작권법 개정에 따른 이용안내
작성자:  

 dew (dewdrop)

추천:  2
파일:     제발_Ans.xlsm (46.5KB) 조회:  1749
제목:   [RE]특정 조건의 항목 가져오기
     
  * 답변하시는 분들께 도움이 되도록 자신의 환경을 아래 항목 옆에 기재해 주세요.

 - 엑셀 버전(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
 
[불량 게시물 신고]  
감사해요정말 감사합니다.
12-11 (13:20)
삭제 ■신고
        
  

작성일 : 2019-12-10(15:30)
최종수정일 : 2019-12-10(15:30)
 


 ◎ 관련글

  제 목   작성자   날짜
특정 조건의 항목 가져오기 감사해요 2019-12-09
[RE]특정 조건의 항목 가져오기 dew 2019-12-10