2016-09-30 148 views
2

我當前的宏將我的數據逐行從工作簿A或工作表A中分離出來,並根據匹配的標題將其分成不同的工作表。我無法進一步將這些表單中的字符串字段拆分。VBA,通過unqiue字符串對工作表中的數據進行排序

例如,我在工作簿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中調用此示例提取。 enter image description here

'用戶'表。我的宏已經這樣做了。

enter image dhereescription

'文檔' 表,我的宏已經這樣做太

enter image description here

'堆棧' 表。我的宏不這樣做。它過濾了記錄的stackoverflow及其相關的列。

enter image description here

希望這有助於。

+0

@Ralph,生病了幾個樣本截圖。 – Jonnyboi

+0

現在更新圖片,希望這可能會讓事情更清晰。 – Jonnyboi

回答

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 

它將在同一工作簿中創建工作表。

相關問題