如何在VBA excel中分离变量并创建新的工作表

Question

到目前为止，我已经有了这段代码。它做了它需要做的事，但我需要它多做一步。现在，它将F column中的名称分离，并为每个名称创建一个新的工作表。但是，我需要一些名字在同一个工作表中。例如，现在如果A,B,C,D都混合在Column F和worksheet 1中，则当前代码将创建4个新的worksheets，其中一个具有A，下一个具有B，等等。但是我需要，例如A和B在同一工作表中。如何做到这一点？

Sub company_statement()
Dim lr As Long
Dim ws As Worksheet
Dim vcol, i As Integer
Dim icol As Long
Dim myarr As Variant
Dim title As String
Dim titlerow As Integer 
vcol = 6
Set ws = Sheets("Company Statement Hanley")
lr = ws.Cells(ws.Rows.Count, vcol).End(xlUp).Row
title = "A1:AE1"
titlerow = ws.Range(title).Cells(1).Row
icol = ws.Columns.Count
ws.Cells(1, icol) = "Unique" 
For i = 2 To lr
On Error Resume Next
If ws.Cells(i, vcol) <> "" And _
Application.WorksheetFunction.Match(ws.Cells(i, vcol), ws.Columns(icol), 0) = 0 Then 
ws.Cells(ws.Rows.Count, icol).End(xlUp).Offset(1) = ws.Cells(i, vcol)
End If
Next 
myarr = Application.WorksheetFunction.Transpose(ws.Columns(icol).SpecialCells(xlCellTypeConstants)) 
ws.Columns(icol).Clear 
For i = 2 To UBound(myarr)
ws.Range(title).AutoFilter field:=vcol, Criteria1:=myarr(i) & ""
If Not Evaluate("=ISREF('" & myarr(i) & "'!A1)") Then 
Sheets.Add(after:=Worksheets(Worksheets.Count)).Name = myarr(i) & ""
Else
Sheets(myarr(i) & "").Move after:=Worksheets(Worksheets.Count)
End If 
ws.Range("A" & titlerow & ":A" & lr).EntireRow.Copy Sheets(myarr(i) & "").Range("A1") 
Sheets(myarr(i) & "").Columns.AutoFit
Next 
ws.AutoFilterMode = False
ws.Activate
End Sub

Answer 1

有目的地使用了许多不同的技术供您使用/学习。祝你好运，希望它能帮助

Option Explicit
Sub main()
Dim wbMain                      As Workbook
Dim wsMain                      As Worksheet
Dim rngMain                     As Range
Dim RngCategoryOne              As Range
Dim RngCategoryTwo              As Range
Dim RngCategoryThree            As Range
Dim rng                         As Range
Dim SheetNames                  As Variant
Dim str                         As Variant
Set wbMain = ThisWorkBook 
Set wsMain = wbMain.Sheets("MAIN")
Set rngMain = wsMain.Range("A1:A10")
For Each rng In rngMain
Select Case rng
Case "A", "B"
If RngCategoryOne Is Nothing Then
Set RngCategoryOne = rng
Else
Set RngCategoryOne = Union(rng, RngCategoryOne)
End If
Case "C"
If RngCategoryTwo Is Nothing Then
Set RngCategoryTwo = rng
Else
Set RngCategoryTwo = Union(rng, RngCategoryTwo)
End If
Case "D"
If RngCategoryThree Is Nothing Then
Set RngCategoryThree = rng
Else
Set RngCategoryThree = Union(rng, RngCategoryThree)
End If
End Select
Next rng
SheetNames = Array("CATEGORY ONE", "CATEGORY TWO", "CATEGORY THREE")
For Each str In SheetNames
Call AddNewWorksheet(wbMain, str)
Next str
wbMain.Sheets("CATEGORY ONE").Range("A1:A" & RngCategoryOne.Count) = RngCategoryOne.Value
wbMain.Sheets("CATEGORY TWO").Range("A1:A" & RngCategoryTwo.Count) = RngCategoryTwo.Value
wbMain.Sheets("CATEGORY THREE").Range("A1:A" & RngCategoryThree.Count) = RngCategoryThree.Value
wsMain.Activate
wsMain.Range("A1").Select
End Sub
Sub AddNewWorksheet(ByRef wb As Workbook, ByVal wsName As Variant)
With wb.Sheets
.Add(after:=wb.Sheets(.Count)).name = wsName
End With
End Sub