| |
* 답변하시는 분들께 도움이 되도록 자신의 환경을 아래 항목 옆에 기재해 주세요.
- 엑셀 버전(95,97,2000,xp,2003,2007):2010
* 아래줄에 질문을 작성하세요 >>
데이터 추출 관련 질문입니다.
해당하는 데이터들의 모든 값 가져오는 방법 질문입니다.
==============[나선랑님 글에 대한 답변입니다]==============
첨부화일 참고하세요...
Sub getData1()
Dim rTable As Range, rRow As Range
Dim rTg As Range
Dim iOffset As Integer, iCol As Integer
Dim rFindCd As Range
Dim sKey As String, sItem As String
Call SpeedOn(True)
With ActiveSheet
Set rTable = .Range("C8").CurrentRegion
Set rTg = .Range("G8")
rTg.CurrentRegion.Clear
End With
'Set oList = CreateObject("System.Collections.SortedList")
rTable.Columns(2).Copy rTg
With rTg.CurrentRegion
.Sort Key1:=.Cells(1), Header:=xlYes
.RemoveDuplicates Columns:=1, Header:=xlYes
End With
rTable.Cells(1).Copy rTg
With rTg.CurrentRegion
.Offset(1).Resize(.Rows.Count - 1).Copy
End With
rTg.Offset(0, 1).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=True
rTg.CurrentRegion.Offset(1).Clear
Application.CutCopyMode = False
For Each rRow In rTable.Offset(1).Resize(rTable.Rows.Count - 1).Rows
If rRow.Cells(1, 3) > 0 Then
sKey = rRow.Cells(1, 1).Text
sItem = rRow.Cells(1, 2).Value
iCol = WorksheetFunction.Match(sItem, rTg.CurrentRegion.Rows(1)) - 1
Set rFindCd = rTg.CurrentRegion.Columns(1).Find(What:=sKey, LookAt:=xlWhole)
If rFindCd Is Nothing Then
If rTg.Offset(1) = "" Then
With rTg.Offset(1)
.NumberFormat = "@"
.Value = sKey
.Offset(0, iCol) = sItem
End With
Else
With rTg.End(xlDown).Offset(1)
.NumberFormat = "@"
.Value = sKey
.Offset(0, iCol) = sItem
End With
End If
Else
rFindCd.Offset(0, iCol) = sItem
End If
End If
Next
With rTg.CurrentRegion
.Rows(1).Interior.ColorIndex = 15
.Cells(1).Select
.Borders.LineStyle = xlContinuous
.Borders.Weight = xlHairline
.Columns.AutoFit
.HorizontalAlignment = xlCenter
End With
Call SpeedOn(False)
End Sub
Sub getData2()
Dim rTable As Range, rRow As Range
Dim rTg As Range
Dim iOffset As Integer
Dim oDic As Object, oList As Object
Dim vKey, vItem
Call SpeedOn(True)
With ActiveSheet
Set rTable = .Range("C8").CurrentRegion
Set rTg = .Range("G8")
End With
Set oDic = CreateObject("Scripting.Dictionary")
For Each rRow In rTable.Offset(1).Resize(rTable.Rows.Count - 1).Rows
If rRow.Cells(1, 3) > 0 Then
vKey = rRow.Cells(1, 1).Text
vItem = rRow.Cells(1, 2).Value
If oDic.Exists(vKey) Then
oDic(vKey).Add rRow.Cells(1, 2).Value
Else
Set oList = CreateObject("System.Collections.ArrayList")
oList.Add vItem
oDic.Add vKey, oList
End If
End If
Next
With rTg.CurrentRegion
.Clear
.Offset(0, 1).EntireColumn.Delete
End With
rTable.Cells(1).Resize(1, 2).Copy rTg
For Each vKey In oDic.keys
iOffset = iOffset + 1
With rTg.Offset(iOffset, 0)
.NumberFormat = "@"
.Value = vKey
End With
rTg.Offset(iOffset, 1) = Join(oDic(vKey).ToArray, "")
Next
With rTg.CurrentRegion
.Rows(1).Interior.ColorIndex = 15
.Cells(1).Select
.Borders.LineStyle = xlContinuous
.Borders.Weight = xlHairline
.Columns.AutoFit
.HorizontalAlignment = xlCenter
End With
Call SpeedOn(False)
End Sub
Sub SpeedOn(Optional bX As Boolean = True)
With Application
.ScreenUpdating = Not bX
.Calculation = IIf(bX, xlCalculationManual, xlCalculationAutomatic)
.EnableEvents = Not bX
.DisplayAlerts = Not bX
End With
End Sub |
|
엑셀에 대한 질문과
답변을 올려주세요. 단, 취지에 맞지 않는 글은 운영자가 삭제합니다.
