VBA，通过unqiue字符串对工作表中的数据进行排序

Question

我当前的宏从工作簿A或工作表A中逐行获取数据，并根据匹配的标题将其拆分为不同的工作表。我无法更进一步，在这些表格中分割字符串字段。

例如，工作簿A，B列中的数据包含10个唯一字符串，如何将字符串x排序为仅一个工作表，并将其余字符串与其他工作表相关联。因此，包含工作表x的行将转到某个工作表，字符串abc将正常运行。

到目前为止，这是我的代码，特别是调出工作簿和工作表名称，使其不是动态的：

Option Explicit

Sub main()
    Dim dsRng As Range
    Dim sht As Worksheet
    Dim AShtColsList As String, BShtColsList As String

    Set dsRng = Workbooks("Workbook A").Worksheets("Sample Extract").Range("A1").CurrentRegion '<--| set your entire data set range in workbook "A" worksheet "ShtA" (change "A" and "ShtA" to your actual names)
    dsRng.Sort key1:=dsRng.Range("A1"), order1:=xlAscending, Header:=xlYes '<--| sort data set range on its 1st column (which is "A", beginning it from column "A")

    With Workbooks("Workbook B") '<--| refer "B" workbook
        For Each sht In .Worksheets(Array("Stack", "Documentation", "Users")) '<--| loop through its worksheets
            GetCorrespondingColumns dsRng, sht, AShtColsList, BShtColsList '<--| build lists of corresponding columns indexes in both workbooks
            CopyColumns dsRng, sht, AShtColsList, BShtColsList '<--| copy listed columns between workbooks
        Next sht
    End With
End Sub

Sub GetCorrespondingColumns(dsRng As Range, sht As Worksheet, AShtColsList As String, BShtColsList As String)
    Dim f As Range, c As Range
    Dim iElem As Long

    AShtColsList = "" '<--| initialize workbook "A" columns indexes list
    BShtColsList = "" '<--| initialize workbook "B" current sheet columns indexes list
    For Each c In sht.Rows(2).SpecialCells(xlCellTypeConstants, xlTextValues) '<--| loop through workbook "B" current sheet headers in row 2     *******
        Set f = dsRng.Rows(1).Find(what:=c.Value, lookat:=xlWhole, LookIn:=xlValues) '<--| look up data set headers row for workbook "B" current sheet current column header
        If Not f Is Nothing Then '<--| if it's been found ...
            BShtColsList = BShtColsList & c.Column & "," '<--| ...update workbook "B" current sheet columns list with current header column index
            AShtColsList = AShtColsList & f.Column & "," '<--| ...update workbook "A" columns list with corresponding found header column index
        End If
    Next c
End Sub

Sub CopyColumns(dsRng As Range, sht As Worksheet, AShtColsList As String, BShtColsList As String)
    Dim iElem As Long
    Dim AShtColsArr As Variant, BShtColsArr As Variant

    If AShtColsList <> "" Then '<--| if any workbook "B" current sheet header has been found in workbook "A" data set headers
        BShtColsArr = Split(Left(BShtColsList, Len(BShtColsList) - 1), ",") '<--| build an array out of workbook "B" current sheet columns indexes list
        AShtColsArr = Split(Left(AShtColsList, Len(AShtColsList) - 1), ",") '<--| build an array out of workbook "A" corresponding columns indexes list
        For iElem = 0 To UBound(AShtColsArr) '<--| loop through workbook "A" columns indexes array (you could have used workbook "A" corresponding columns indexes list as well)
            Intersect(dsRng, dsRng.Columns(CLng(AShtColsArr(iElem)))).Copy sht.Cells(2, CLng(BShtColsArr(iElem))) '<--| copy data set current column into workbook "B" current sheet corresponding column starting from row 2     *******
        Next iElem
    End If
End Sub

感谢。

修改

完全提取物。在工作簿B中调用此示例提取。

＆＃39;用户＆＃39;片。我的宏已经这样做了。

＆＃39;文档＆＃39; Sheet，我的宏也已经这样做了

＆＃39;堆栈＆＃39;片。我的宏不会这样做。它过滤了记录stackoverflow及其相关列。

希望这有帮助。

Answer 1

将您的数据保存在名为“data”的工作表中。以下代码将为B列中的每个唯一值生成具有相应值的数据的单独表格。

Dim data, sht As Worksheet
Dim rng As Range
Dim counter As Long

Set data = ThisWorkbook.Sheets("data")
data.Activate
Range("B:B").Copy
Range("H:H").PasteSpecial xlPasteValues
Range("H:H").RemoveDuplicates Columns:=1, Header:=xlYes
Set rng = data.Range("H2")

Do While rng.Value <> ""
Set sht = ThisWorkbook.Worksheets.Add
sht.Name = rng.Value
data.Activate
ActiveSheet.AutoFilterMode = False
Range("A1").AutoFilter field:=2, Criteria1:=rng.Value
Range("A1:C1").Select
Range(Selection, Selection.End(xlDown)).Select
Selection.SpecialCells(xlVisible).Copy
sht.Activate
Range("A1").PasteSpecial xlPasteValues
Range("A1").Activate
Set rng = rng.Offset(1, 0)
Loop

它将在同一工作簿中创建工作表。