將數據發送到Excel中的多個工作表

Question

我正在研究一個分配到不同樓層的人員的主要名單。在指定樓層的主欄目中，我希望將這些信息轉移到單獨的專用於該樓層的工作表中，共有八層樓，並有自己的價值（1等於一樓工作表，2等於二樓工作表等）。

姓名聯繫電話分配樓層（如果分配到第五層）將所有先前的信息移動到第5層工作表。

如果我想要做的事情仍然聽起來不清楚，請告訴我，但這是描述它的最好方法。寧願不使用VBA，但如果沒有其他人會欣賞完整的代碼佈局。

Answer 1

好問題。

Column A : Header in A1 = Country, A2:A? = Country names 
Column B : Header in B1 = Name, B2:B? = Names 
Column C : Header in C1 = Gender, C2:C? = F or M 
Column D : Header in D1 = Birthday, D2:D? = Dates 


1: Criteria in the code (=Netherlands, see the tips below the macro) 
2: Filter on ActiveCell value 
3: Filter on Range value (D1 in this example) 
4: Filter on InputBox value 

Sub Copy_With_AutoFilter1() 
'Note: This macro use the function LastRow 
    Dim My_Range As Range 
    Dim CalcMode As Long 
    Dim ViewMode As Long 
    Dim FilterCriteria As String 
    Dim CCount As Long 
    Dim WSNew As Worksheet 
    Dim sheetName As String 
    Dim rng As Range 

    'Set filter range on ActiveSheet: A1 is the top left cell of your filter range 
    'and the header of the first column, D is the last column in the filter range. 
    'You can also add the sheet name to the code like this : 
    'Worksheets("Sheet1").Range("A1:D" & LastRow(Worksheets("Sheet1"))) 
    'No need that the sheet is active then when you run the macro when you use this. 
    Set My_Range = Range("A1:D" & LastRow(ActiveSheet)) 
    My_Range.Parent.Select 

    If ActiveWorkbook.ProtectStructure = True Or _ 
     My_Range.Parent.ProtectContents = True Then 
     MsgBox "Sorry, not working when the workbook or worksheet is protected", _ 
       vbOKOnly, "Copy to new worksheet" 
     Exit Sub 
    End If 

    'Change ScreenUpdating, Calculation, EnableEvents, .... 
    With Application 
     CalcMode = .Calculation 
     .Calculation = xlCalculationManual 
     .ScreenUpdating = False 
     .EnableEvents = False 
    End With 
    ViewMode = ActiveWindow.View 
    ActiveWindow.View = xlNormalView 
    ActiveSheet.DisplayPageBreaks = False 

    'Firstly, remove the AutoFilter 
    My_Range.Parent.AutoFilterMode = False 

    'Filter and set the filter field and the filter criteria : 
    'This example filter on the first column in the range (change the field if needed) 
    'In this case the range starts in A so Field 1 is column A, 2 = column B, ...... 
    'Use "<>Netherlands" as criteria if you want the opposite 
    My_Range.AutoFilter Field:=1, Criteria1:="=Netherlands" 

    'If you want to filter on a cell value you can use this, use "<>" for the opposite 
    'This example uses the activecell value 
    'My_Range.AutoFilter Field:=1, Criteria1:="=" & ActiveCell.Value 

    'This will use the cell value from A2 as criteria 
    'My_Range.AutoFilter Field:=1, Criteria1:="=" & Range("A2").Value 

    ''If you want to filter on a Inputbox value use this 
    'FilterCriteria = InputBox("What text do you want to filter on?", _ 
    '        "Enter the filter item.") 
    'My_Range.AutoFilter Field:=1, Criteria1:="=" & FilterCriteria 

    'Check if there are not more then 8192 areas(limit of areas that Excel can copy) 
    CCount = 0 
    On Error Resume Next 
    CCount = My_Range.Columns(1).SpecialCells(xlCellTypeVisible).Areas(1).Cells.Count 
    On Error GoTo 0 
    If CCount = 0 Then 
     MsgBox "There are more than 8192 areas:" _ 
      & vbNewLine & "It is not possible to copy the visible data." _ 
      & vbNewLine & "Tip: Sort your data before you use this macro.", _ 
       vbOKOnly, "Copy to worksheet" 
    Else 
     'Add a new Worksheet 
     Set WSNew = Worksheets.Add(After:=Sheets(ActiveSheet.Index)) 

     'Ask for the Worksheet name 
     sheetName = InputBox("What is the name of the new worksheet?", _ 
          "Name the New Sheet") 

     On Error Resume Next 
     WSNew.Name = sheetName 
     If Err.Number > 0 Then 
      MsgBox "Change the name of sheet : " & WSNew.Name & _ 
       " manually after the macro is ready. The sheet name" & _ 
       " you fill in already exists or you use characters" & _ 
       " that are not allowed in a sheet name." 
      Err.Clear 
     End If 
     On Error GoTo 0 

     'Copy/paste the visible data to the new worksheet 
     My_Range.Parent.AutoFilter.Range.Copy 
     With WSNew.Range("A1") 
      ' Paste:=8 will copy the columnwidth in Excel 2000 and higher 
      ' Remove this line if you use Excel 97 
      .PasteSpecial Paste:=8 
      .PasteSpecial xlPasteValues 
      .PasteSpecial xlPasteFormats 
      Application.CutCopyMode = False 
      .Select 
     End With 

     ' If you want to delete the rows that you copy, also use this 
     ' With My_Range.Parent.AutoFilter.Range 
     '  On Error Resume Next 
     '  Set rng = .Offset(1, 0).Resize(.Rows.Count - 1, .Columns.Count) _ 
     '    .SpecialCells(xlCellTypeVisible) 
     '  On Error GoTo 0 
     '  If Not rng Is Nothing Then rng.EntireRow.Delete 
     ' End With 

    End If 

    'Close AutoFilter 
    My_Range.Parent.AutoFilterMode = False 

    'Restore ScreenUpdating, Calculation, EnableEvents, .... 
    My_Range.Parent.Select 
    ActiveWindow.View = ViewMode 
    If Not WSNew Is Nothing Then WSNew.Select 
    With Application 
     .ScreenUpdating = True 
     .EnableEvents = True 
     .Calculation = CalcMode 
    End With 

End Sub 


Function LastRow(sh As Worksheet) 
    On Error Resume Next 
    LastRow = sh.Cells.Find(What:="*", _ 
          After:=sh.Range("A1"), _ 
          Lookat:=xlPart, _ 
          LookIn:=xlValues, _ 
          SearchOrder:=xlByRows, _ 
          SearchDirection:=xlPrevious, _ 
          MatchCase:=False).Row 
    On Error GoTo 0 
End Function 

來自此鏈接。

https://www.rondebruin.nl/win/s3/win006_1.htm