[VBA] 시트를 순환하며 조건에 맞는 자료 전부 가져오기

현재 Sheet 를 제외하고 모든 시트를 순환하면서 조건을 만족하는 데이터를 복사해오는 VBA 코드이다.

조건에 맞는 값이 들어있는 셀을 찾는 것은 Find 함수를 이용하고

여기에 각 시트만 순환하는 For Each sht in Sheets 만 더 추가한 것이다.

그리고 If sht.Name <> ActiveSheet.Name Then   '// 현재 시트와 순환하는 시트이름이 다르면

기존 FIND VBA 함수를 약간 응용한 것이라고 보면 된다.

Option Explicit
Sub 시트순환결과가져오기()
    Dim sht As Worksheet    '// 각 시트를 순환할 변수
    Dim strAddr As String     '// 임시주소를 저장할 변수
    Dim C As Range
    Dim FindCell As String    '// 찾는 셀이 들어간 변수
   
    If Len(Cells(3, "C")) = 0 Then Exit Sub
    FindCell = Cells(3, "C").Value
    Application.ScreenUpdating = False      '// 화면 업데이트 일시 정지
    Range("A9:H" & Rows.Count).ClearContents    '// A9 셀부터 H 마지막 셀까지 전부 내용 지우기
   
    For Each sht In Sheets
         If sht.Name <> ActiveSheet.Name Then   '// 현재 시트와 순환하는 시트이름이 다르면

            With sht.Columns(2)     '// 찾을 값이 B열에 있을 경우
               Set C = .Find(what:=FindCell, Lookat:=xlPart)    '// 부분적으로 일치하는 걸 찾기
               If Not C Is Nothing Then
                   strAddr = C.Address  '// 찾은 셀의 주소를 변수에 넣음
                   Do
                       C.EntireRow.Copy Cells(Rows.Count, "A").End(3)(2)    '// 찾는 값이 들어있는 행 전체를 복사
                       Set C = .FindNext(C)
                   Loop While Not C Is Nothing And C.Address <> strAddr
               End If
            End With
        End If
    Next sht
End Sub

특정 셀에 데이터 입력하고 엔터키를 치면 자동으로 조건에 맞는 데이터를 가져오는 VBA 코드로 위의 코드와 동일한데 달라진 셀이 어디인지만 찾아보면 된다.

Private Sub Worksheet_Change(ByVal FindCell As Range)
    Dim sht As Worksheet    '// 각 시트를 순환할 변수
    Dim strAddr As String     '// 임시주소를 저장할 변수
    Dim C As Range
   
    If FindCell.Address <> "$C$3" Then Exit Sub
    Application.ScreenUpdating = False      '// 화면 업데이트 일시 정지
    Range("A9:H" & Rows.Count).ClearContents    '// A9 셀부터 H 마지막 셀까지 전부 내용 지우기
   
    For Each sht In Sheets
         If sht.Name <> ActiveSheet.Name Then   '// 현재 시트와 순환하는 시트이름이 다르면
            With sht.Columns(2)     '// 찾는 값이 B열에 있을 경우
               Set C = .Find(what:=FindCell, Lookat:=xlPart)    '// 부분적으로 일치하는 걸 찾기
               If Not C Is Nothing Then
                   strAddr = C.Address  '// 찾은 셀의 주소를 변수에 넣음
                   Do
                       C.EntireRow.Copy Cells(Rows.Count, "A").End(3)(2)    '// 찾는 값이 들어있는 행 전체를 복사
                       Set C = .FindNext(C)
                   Loop While Not C Is Nothing And C.Address <> strAddr
               End If
            End With
        End If
    Next sht
End Sub