Excel VBA - 드롭 다운 목록의 범위를 기반으로 매크로 실행

Question

VBA 클래스부터 몇 년이 지났으므로 "Excel VBA for Dummies"서적에 쓰는 것처럼 응답하십시오.

G 열에서 범위 G2 : G1001의 각 셀은 내 통합 문서의 모든 워크 시트에 대한 개별 데이터 유효성 검사 드롭 다운 목록입니다. 나는 "G2"셀의 드롭 다운에서 "Questar"를 선택하면 A2 : F2 셀을 복사하여 첫 번째 빈 행의 "Questar"라는 제목의 워크 시트에 붙여 넣습니다. 그건 모두 잘 작동합니다.

그러나 내 문제는 G2 셀에서만 작동한다는 것입니다. 2-1001 행에 데이터가 있고 모든 셀 G2에서 작동해야합니다. G1001. 여기에 지금까지 무엇을하고 세포 "G2"작동 :

Private Sub Worksheet_Change(ByVal Target As Range) 
    If Not Intersect(Target, Range("G2:G1001")) Is Nothing Then 
     Select Case Range("G2") 
      Case "Questar": Questar 
     End Select 
    End If 
End Sub 

나는 선택 케이스 범위 ("G2")는 변경할 필요가 있다고 생각하지만 난 모든 노력을했다.

여기 내 Questar 매크로 코드 :

Sub Questar() 

    Worksheets("AFCU Auto-Add").Range(ActiveCell.Offset(0, -6), ActiveCell.Offset(0, -1)).Copy 
    Worksheets("Questar").Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).PasteSpecial xlPasteValues 
    Application.CutCopyMode = False 
    Application.ScreenUpdating = True 

    Sheets("AFCU Auto-Add").Select 
    Range(ActiveCell.Offset(0, -6), ActiveCell.Offset(0, -1)).Select 
    Application.CutCopyMode = False 
    Selection.ListObject.ListRows(1).Delete 
    Range("G2").Select 

End Sub 

나는 결국 더 많은 사례를 추가 할 것입니다하지만 난 더 케이스 및 매크로를 추가하기 전에 하나 개의 워크 시트가 제대로 작동 싶어. 어떤 제안?

Answer 1

편집 :`선택 케이스 범위를 대체 할

이

Private Sub Worksheet_Change(ByVal Target As Range) 
    Dim rng As Range, c As Range, rngDel As Range 

    On Error GoTo haveError 

    Set rng = Intersect(Target, Range("G2:G1001")) 

    If Not rng Is Nothing Then 
     For Each c In rng.Cells 
      If Len(c.Value) > 0 Then 
       'copy to appropiate sheet 
       With ThisWorkbook.Worksheets(c.Value).Cells(Rows.Count, 1).End(xlUp) 
        .Offset(1, 0).Resize(1, rng.Cells.Count).Value = _ 
            c.EntireRow.Range("A1:F1").Value 
       End With 

       'build up a range of rows to delete... 
       If rngDel Is Nothing Then 
        Set rngDel = c 
       Else 
        Set rngDel = Union(c, rngDel) 
       End If 

      End If 
     Next c 

     'any rows to delete? 
     If Not rngDel Is Nothing Then 
      Application.EnableEvents = False 
      rngDel.EntireRow.Delete 
      Application.EnableEvents = True 
     End If 

    End If 

    Exit Sub 

haveError: 
    'make sure to re-enable events in the case of an error 
    Application.EnableEvents = True 

End Sub