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

본문 바로가기

vb6.0/vba

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

회원사진
하나를하더라도최선을
2020-09-22 23:32 5,690 0
  • - 첨부파일 : 2020-09-21dirId102020101docId368695835지식인 질문.xlsm (399.3K) - 다운로드

본문



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

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

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

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

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

50b756edc50f03452423195dd81c2b67_1600785074_1497.png
 

이후 중략

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

50b756edc50f03452423195dd81c2b67_1600785044_0792.png


조건이 무엇일까?

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

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

50b756edc50f03452423195dd81c2b67_1600785024_632.png

아래는 관련 동영상 입니다

 

 

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

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

50b756edc50f03452423195dd81c2b67_1600784987_6825.png

 

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(2345), 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(23), 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(18)) Then Cells(18).CurrentRegion.Clear
                ActiveSheet.Cells(18).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(19), Cells(110)))
            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 StringAs Boolean
    On Error GoTo ErrPass
    x.Add value, value
    xAdd = True
ErrPass:
End Function


댓글목록0

등록된 댓글이 없습니다.
게시판 전체검색