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

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

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

​

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

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

엑셀 매크로&VBA 바이블:실무에 최적화된 엑셀 사용서, 한빛미디어 40,500원(포스팅일기준)

엑셀 2016 매크로&VBA 무작정 따라하기:기본+회사실무, 길벗 19,800원(포스팅일기준)

엑셀 2016 매크로 & VBA 바이블:회사에서 필요한 코드는 모두 있다!, 한빛미디어 40,500원(포스팅일기준)