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에서이 샘플 추출물을 호출하십시오.

'사용자'시트. 내 매크로 이미 있습니다.

'문서'시트, 내 매크로는 이미이 너무

'스택'시트 않습니다. 내 매크로는이 작업을 수행하지 않습니다. 그것은 레코드 stackoverflow 및 관련 컬럼을 필터링했습니다.

는 희망이 도움이됩니다.

Answer 1

데이터를 "데이터"라는 시트에 저장하십시오. 아래 코드는 해당 값의 데이터로 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 

동일한 통합 문서에 시트가 생성됩니다.