[vba] OLEDB를 활용한 시트 데이터 검색 및 추출을 통한 데이터 정리

728x90

간만에 흥미를 가질만한 질문이 올라왔습니다.

많은 데이터중에서 특정 조건으로 데이터를 추출하고자 합니다.

조금 이해는 불가하지만 나름 얻고자 하는 데이터가 무엇인지 한참 고민을 했습니다.

1차질문(엑셀 VBA 질문 드립니다.), 2차질문(1:1 질문)

아래와 같은 데이터가 있습니다.

이후 중략

이 데이터를 기반으로 아래와 같이 뽑고자 합니다.

조건이 무엇일까?

질문을 여러번 읽어보고 감이 왔습니다.

그래서 결과를 아래처럼 뽑아냈습니다.

아래는 관련 동영상 입니다

아래는 동영상에서 사용된 vba 매크로 소스코드 입니다

우선 도구 - 참조 에서 아래처럼 참조를 추가합니다.

Sub program1472_com()
    Application.ScreenUpdating = False
    Do While Worksheets.Count > 1
        Worksheets(Worksheets.Count).Delete
    Loop
    Sheets("Sheet1").Copy After:=Sheets(Sheets.Count)
    Columns("D:D").Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
    Columns("C:C").TextToColumns Destination:=Range("C1"), Space:=True
    Range("D1").value = "시간"
    If ActiveSheet.AutoFilterMode Then ActiveSheet.UsedRange.AutoFilter
    ActiveSheet.ListObjects.Add(xlSrcRange, ActiveSheet.UsedRange.Resize(, 6), , xlYes).Name = "IT_HUB"
 
    Dim rs As New ADODB.Recordset
    Dim strSQL As String, strConn As String
    Dim i As Integer, C As Range, V As Variant
  
    ActiveSheet.Name = "IT_HUB"
 
    ActiveSheet.UsedRange.Resize(, 6).Sort Key1:=[A2], Order1:=2, Header:=xlYes
    ActiveSheet.Range("IT_HUB").RemoveDuplicates Columns:=Array(2, 3, 4, 5), Header:=xlYes
    ActiveSheet.UsedRange.Resize(, 6).Sort Key1:=[A2], Order1:=1, Header:=xlYes
    Columns("G").Resize(, ActiveSheet.UsedRange.Columns.Count).EntireColumn.Delete
    [M1].Resize(, 13).value = Array("일자", "서해북부", "서해중부", "서해남부", "남해서부", "제주도해상", "남해동부", "동해남부", "동해중부", "동해북부", "대화퇴", "규슈", "연해주")
    strConn = "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & ThisWorkbook.Path & "\" & ActiveWorkbook.Name & ";" & "Extended Properties=Excel 12.0;"
    
    Dim x As New Collection
    For Each C In Range(Cells(2, 3), Cells(Rows.Count, 3))
        xAdd x, C
    Next
    
    For Each V In x
        If IsDate(V) Then
            strSQL = "SELECT [지역], [예보시각], [시간], [예보] FROM [IT_HUB$] WHERE [예보시각] = #" & V & "#"
            rs.Open strSQL, strConn, adOpenForwardOnly, adLockReadOnly, adCmdText
            If rs.EOF Then
    '            MsgBox "조회조건에 해당하는 자료가 없습니다."
            Else
        '        For i = 1 To rs.Fields.Count
        '            Cells(1, i + 7).Value = rs.Fields(i - 1).Name
        '        Next
                If Len(Cells(1, 8)) Then Cells(1, 8).CurrentRegion.Clear
                ActiveSheet.Cells(1, 8).CopyFromRecordset rs
            End If
            
            Set C = Cells(Rows.Count, 13).End(3)(2)
            ActiveSheet.Range("$H$1").CurrentRegion.Sort Key1:=[J1], Order1:=2, Header:=xlNo
            ActiveSheet.Range("$H$1").CurrentRegion.RemoveDuplicates Columns:=1, Header:=xlNo
            ActiveSheet.Range("$H$1").CurrentRegion.Sort Key1:=[J1], Order1:=1, Header:=xlNo
            C.Next.Resize(, 12).FormulaR1C1 = "=IFERROR(VLOOKUP(R1C,R1C8:R14C11,4,0),"""")"
            C.Next.Resize(, 12).value = C.Next.Resize(, 12).value
            C = Join(Array(Cells(1, 9), Cells(1, 10)))
            rs.Close
            Set rs = Nothing
        End If
    Next
    Columns("M:Y").EntireColumn.AutoFit
    [M1].CurrentRegion.Borders.LineStyle = 1
    MsgBox "완료"
End Sub
 
Function xAdd(ByRef x As Collection, ByVal value As String) As Boolean
    On Error GoTo ErrPass
    x.Add value, value
    xAdd = True
ErrPass:
End Function