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

 참서리 (k5953)

추천:  2
파일:     summary_data.xls (34KB) 조회:  1524
제목:   [RE]데이터 추출 관련 질문입니다.
     
  '-----------------------
Sub summary()
'-----------------------
    
    ' [코드] 범위
    Dim rX As Range: Set rX = Range("D4", [D4].End(xlDown))
    ' collection 객체 생성
    Dim colX As New Collection
    Dim c As Range
    
    '---------------------------
    On Error Resume Next
    '---------------------------
    Dim K As Variant, V As Variant, iCnt As Long, itemX As Variant
    Dim sKey As String
    
    '-----------------------
    For Each c In rX.Cells
    '-----------------------
    
        ' K_코드,     Y_분류
        K = CStr(c.Value): V = c.Offset(0, 1).Value
        ' 수량
        iCnt = c.Offset(0, 2).Value
        
        ' 수량이 0이면 last_line 라벨로 이동
        If iCnt = 0 Then GoTo last_line
        
        ' 키에 해당하는 값 구하기
        ' 키가 없으면 Err발생 즉 err.number>0
        itemX = colX.Item(K)
        
        ' 에러 나면 즉, 새로운 키일 경우
        If Err.Number Then ' 에러나면
            ' key를 ,를 기준으로 연결
            If sKey = "" Then sKey = K Else sKey = sKey & "," & K
            ' key, value추가
            colX.Add V, K
        
        Else ' 에러 안 나면, 즉 기존 키가 있음
                        
            V = itemX & V
            ' 항목 지우기
            colX.Remove K
            ' 다시 추가
            colX.Add V, K
        
        End If
        
        ' error초기화
        Err.Number = 0
            
' 수량이 0일 경우 지금 label로 이동
last_line:
       
       
    '-----
    Next c
    '-----
    
    ' Error Handler 초기화
    On Error GoTo 0
    
    ' 붙여넣을 위치
    Dim rT As Range: Set rT = [H4]
    ' 기존 자료 지우기
    rT.CurrentRegion.ClearContents
    
    '--------------------------------
    For Each key In Split(sKey, ",")
    '--------------------------------
        ' 서식을 텍스트
        rT.NumberFormat = "@"
        rT.Value = key
        rT.Offset(, 1).Value = colX.Item(key)
        
        ' 바로 아래 셀로 이동
        Set rT = rT.Offset(1)
        
    Next key
    
    Set colX = Nothing
    
    
End Sub
 
[불량 게시물 신고]  
        
  

작성일 : 2019-11-13(15:18)
최종수정일 : 2019-11-13(15:18)
 


 ◎ 관련글

  제 목   작성자   날짜
데이터 추출 관련 질문입니다. 나선랑 2019-11-11
[RE]데이터 추출 관련 질문입니다. 참서리 2019-11-13
[RE]데이터 추출 관련 질문입니다. dew 2019-11-12