데이터를 필터링하고 정보를 새 시트에 복사하는 매크로

Question

주어진 시트의 코드를 필터링하고 모든 필터링 된 정보를 새 시트에 복사하는 매크로를 만드는 사람이 도와주십시오.

나는 코드 AC의 최대 목록 인 B18까지 올라갔습니다.

작업해야하는 코드는 다른 시트에 있습니다. 매크로가이 코드를 찾아보고 B18에서 필터링하도록합니다. 모든 결과 정보가 새 시트에 복사됩니다.

도움 주셔서 감사합니다.

이것은 내가 가지고있는 데이터입니다. 행 13, 15 및 17은 항상 비어 있으며 표제의 일부입니다. 별도의 코드 시트에서

 B C D E F G H 
12 Codes Desc AP TP CP DP LP 

13       
14   TEP Q1 PR1 Q1 LT LR1  
15       
16 ABC xx xx xx xx xx xx  
17        
18 ab3 xx xx xx xx xx xx 

19 ab4 xx xx xx xx xx xx 

20 ab5 xx xx xx xx xx xx 

21 bd2 xx xx xx xx xx xx 

22 bd3 xx xx xx xx xx xx 

23 bd4 xx xx xx xx xx xx 

24 bd4 xx xx xx xx xx xx 

25 bd6 xx xx xx xx xx xx 

26 bd7 xx xx xx xx xx xx 

27 bd7 xx xx xx xx xx xx 

28 bd9 xx xx xx xx xx xx 

, 나는

Codes 
ab3 
bd4 

지금 나는 새로운 시트에 아래와 같이 위의 코드와 결과를 필터링 할 찾아 볼에 대한 코드의 목록을 가지고 :

B C D E F G 
1 Codes Desc AP TP CP DP 
2       
3   TEP Q1 PR1 Q1 LT LR1 
4       
5 ABC xx xx xx xx xx xx 

6       
7 ab3 xx xx xx xx xx xx 

8 bd4 xx xx xx xx xx xx 

9 bd4 xx xx xx xx xx xx 

Answer 1

이 트릭을 수행 할 것입니다. 시트의 이름을 바꾸고 범위를 적절하게 다시 정의하십시오.

Option Explicit 

Sub CopyRowsThatHaveTheRightCode() 

    ' Assuming: 
    ' Sheet1 is source sheet 
    ' Sheet3 is destination sheet 
    ' Codes are placed in Sheet2, starting at A2. 

    Dim iSourceRow As Long 
    Dim iDestinationRow As Long 
    Dim iCode As Long 
    Dim varCodes As Variant 
    Dim booCopyThisRow As Boolean 

    ' Copy headers (assuming you want this) 
    Worksheets("Sheet1").Range("B12:AC16").Copy _ 
     Destination:=Worksheets("Sheet3").Range("B12:AC16") 

    ' Get the pass codes 
    varCodes = Worksheets("Sheet2").Range("A2").Resize(2, 1) 
    ' Or wherever your codes are. 

    ' Loop through all rows in source sheet 
    iDestinationRow = 0 
    For iSourceRow = 1 To 11 ' or however many rows you have 
     booCopyThisRow = False 
     For iCode = LBound(varCodes, 1) To UBound(varCodes, 1) 
      If varCodes(iCode, 1) _ 
       = Worksheets("Sheet1").Range("B18").Cells(iSourceRow, 1) Then 
       ' Code matches. 
       booCopyThisRow = True 
       Exit For 
      End If 
     Next iCode 
     If booCopyThisRow = True Then 
      ' Copy into next available destination row. 
      iDestinationRow = iDestinationRow + 1 
      Worksheets("Sheet1").Range("B18").Cells(iSourceRow, 1).Resize(1, 28).Copy _ 
       Destination:=Worksheets("Sheet3").Range("B18").Cells(iDestinationRow, 1) 
     End If 
    Next iSourceRow 


End Sub