宏來過濾數據並將信息複製到新工作表

請有人可以幫助我做一個宏來過濾給定工作表中的代碼，然後將所有過濾的信息複製到新工作表。宏來過濾數據並將信息複製到新工作表

我有一個很大的代碼進入B18到AC AC。

我需要使用的代碼位於不同的工作表中。我希望宏在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

來源

2011-04-21 KIA

我想你將不得不向我們展示你想要完成的一個例子。現在我完全不明白。 – 2011-04-21 16:16:09

對不起，再次。但我希望在Excel表格中包含一個表格格式，但格式又一次變得平坦了。 – KIA 2011-04-26 11:23:40

仍然很神祕。你只是試圖將A列中的值與「過濾器」列表中的值匹配的行復制到新工作表中？整行是應該複製的，還是僅列A：AC？另外，請格式化爲'code'來獲得固定寬度的字體，並正確對齊列，否則很難閱讀。 – 2011-04-26 12:08:43

這將做到這一點。重命名工作表並根據需要重新定義範圍。

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

來源

2011-04-27 18:54:56

宏來過濾數據並將信息複製到新工作表

回答

相關問題