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。
试过并测试过。
我将进一步的测试给你。