Excel中：行中的特定列複製到新的工作表

Question

我有一個主表，我輸入以下內容：

Name 5AM 8AM 3PM Room Comment 
John  X    1A Blah  
Peter X X X 2B Some Blah 
Ann   X   3C Some more Blah 

從工作表 主要

除此之外，我有3人按照時間。換句話說，其他工作表名稱是5AM,8AM和3PM。基本上，我試圖填寫每個工作表，給定相應的時間標記爲X。

因此工作表5AM應該具有以下內容。

Name Room Comment 
John  1A Blah  
Peter 2B Some Blah 

工作表上午8點應具有以下。

Name Room Comment 
Peter 2B Some Blah 
Ann  3C Some more Blah 

工作表3PM應具有以下。

Name Room Comment 
Peter 2B Some Blah 

我開始使用的主要工作創造了一些代碼：

Private Sub Worksheet_Change(ByVal Target As Range) 

Sheets("10AM").Range("A1").End(xlup).Offset(1, 0) 

End Sub 

，但它不是真正的工作了。

Answer 1

試試這個：

Sub test() 

Dim ws As Worksheet, fiveAM As Worksheet, eightAM As Worksheet, ninePM As Worksheet 
Dim wb As Workbook 
Dim lrow As Long, i As Integer 
Dim shname As String 
Dim columntocopy As Range, rowtocopy As Range, rngtocopy As Range 

Set wb = ThisWorkbook 
Set ws = wb.Sheets("MAIN") 
Set fiveAM = wb.Sheets("5AM") 
Set eightAM = wb.Sheets("8AM") 
Set ninePM = wb.Sheets("9PM") 
Set columntocopy = ws.Range("A:A,E:E,F:F") 

With ws 
    lrow = .Range("A" & .Rows.Count).End(xlUp).Row 
    For i = 0 To 2 
     .AutoFilterMode = False 
     shname = .Range("B1").Offset(0, i).Value 
     .Range("B1:B" & lrow).Offset(0, i).AutoFilter Field:=1, Criteria1:="X" 
     Set rowtocopy = .Range("A1:A" & lrow).Offset(1, 0).SpecialCells(xlCellTypeVisible).EntireRow 
     Set rngtocopy = Intersect(rowtocopy, columntocopy) 
     rngtocopy.Copy 
     Select Case shname 
     Case "5AM": fiveAM.Range("A" & fiveAM.Rows.Count).End(xlUp).Offset(1, 0).PasteSpecial xlPasteValues 
     Case "8AM": eightAM.Range("A" & eightAM.Rows.Count).End(xlUp).Offset(1, 0).PasteSpecial xlPasteValues 
     Case "9PM": ninePM.Range("A" & ninePM.Rows.Count).End(xlUp).Offset(1, 0).PasteSpecial xlPasteValues 
     End Select 
    Next 
    .AutoFilterMode = False 
End With 
Application.CutCopyMode = False 
End Sub 

我假設你的數據在每片起價爲Column A。
試過並測試過。
我將進一步的測試給你。