ABOUT ME

-

Today
-
Yesterday
-
Total
-
  • 표 변환하기(셀삽입)
    VB(A) 2019.02.18 19:43


    https://cafe.naver.com/excelmaster/160211의 질문입니다.


    왼쪽 표를 오른쪽 표로 변환하는데

    F는 각 목록별로 값을 가지고 있어서 셀을 삽입하는 것이 까다로웠습니다.

    결국 순환문을 몇 번을 써서 해결했네요.

    로직을 짜는 것이 모든 코딩의 어려운 점인 것 같습니다.


    조금 더 고급진 코딩을 하고 싶은데

    벽에 부딪힌 거 같네요.


    질문.xlsm


    Option Explicit
    Option Base 1
    Sub Macro()
     
        Dim FirstTable As Range
        Dim SecondTable As Range
        Dim SingleRange As Range
        Dim i As Integer
        Dim ToF As String
        
        Application.ScreenUpdating = False
        
        Set FirstTable = Range("A1").CurrentRegion  '첫번째 테이블
        With Range("F3")    '두번째테이블의 제목열
            Set SecondTable = Range(.Cells, .End(xlToRight))
        End With
        
        For Each SingleRange In SecondTable '두번째 테이블의 제목열 순환
        
            With FirstTable
            
                On Error Resume Next    '첫번째 테이블 필터 해제
                    ActiveSheet.ShowAllData
                On Error GoTo 0
                
                .AutoFilter Field:=1, Criteria1:=SingleRange    '제목열 기준으로 첫번째 테이블 필터
                .AutoFilter Field:=4, Criteria1:="O"    '유의미성 O 필터
                
            End With
            
            ToF = IsMeaning(FirstTable.Columns(2))  '각 목록별 유의미성 추출
            Columns(SingleRange.Column).SpecialCells(2).Replace What:="F", _
                    Replacement:=ToF, LookAt:=xlWhole    'F를 유의미성으로 바꾸기
            
        Next SingleRange
        
        Call MakeCells  '유의미성을 셀분할하여 각 셀에 삽입하는 프로시저 호출
        
        Application.ScreenUpdating = True
        
    End Sub
     
    Function IsMeaning(DataRange As Range) As String
    '목록별 유의미성 추출
     
        Dim SingleRange As Range
        Dim v() As String
        Dim i As Integer
        Dim LoopRange As Range
        
        With DataRange  '필터링 되어 화면에 보이는 부분만 순환
            Set LoopRange = .Offset(1).Resize(.Rows.Count - 1).SpecialCells(12)
        End With
        
        ReDim v(LoopRange.Cells.Count)
        
        For Each SingleRange In LoopRange   '유의미성을 배열에 삽입
        
            i = i + 1
                
            With SingleRange
                v(i) = .Value & "-" & .Offset(, 1)
            End With
        Next
            
        IsMeaning = Join(v, ",")
        ActiveSheet.ShowAllData
     
    End Function
     
    Sub MakeCells()
    '셀 분할 후 유의미성 나누어 삽입하기
      
        Dim i As Integer
        Dim uB As Integer
        Dim SingleRange As Range
        Dim EachRange As Range
        Dim tmp() As Integer
        Dim j As Integer
        Dim a As Integer
        Dim ColumnCount As Integer
        Dim MaxUB As Integer
        
        '열 갯수(예시에서는 8개임(오징어~농어))
        ColumnCount = Range("F3").CurrentRegion.Columns.Count
        
        '밑에서 위로 순환하며 T가 아니면 셀삽입
        For i = Cells(Rows.Count, "F").End(3).Row To 5 Step -1
            
            j = 1
            With Cells(i, "F")
                Set EachRange = Range(.Cells, .End(xlToRight))
            End With
            
            For Each SingleRange In EachRange
                
                With SingleRange    '유의미성일 때 셀삽입할 칸수를 배열에 삽입
                    If .Value <> "T" Then
                        uB = UBound(Split(.Value, ","))
                        ReDim Preserve tmp(j)
                        tmp(j) = uB
                        j = j + 1
                    End If
                End With
                
            Next
            
            '유의미성이 있으면 셀 삽입
            If j > 1 Then
                
                MaxUB = WorksheetFunction.Max(tmp)  '총 늘릴 행 수
                Cells(i + 1"F").Resize(MaxUB, ColumnCount).Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
                
                '같은 열을 한번 더 순환하며 빈칸 채우기
                For Each SingleRange In EachRange
                
                    With SingleRange
                        Select Case .Value
                            Case "T"    'T일 때 T 채우기
                                .Resize(MaxUB + 1).Value = "T"
                            Case Else   '유의미성일 때 각 셀에 출력
                                .Resize(MaxUB + 1).Value = Application.Transpose(Split(.Value, ","))
                        End Select
                    End With
                    
                Next
                
            End If
            
        Next
        
        '선 긋고 열너비 자동 맞춤
        With Range("F5").CurrentRegion
            .Borders.LineStyle = xlContinuous
            .Columns.AutoFit
        End With
     
    End Sub
     
    cs


    댓글 0