既に存在する複数のタブにデータを分割する

Question

すでにブックに存在するタブ名に基づいてデータを分割したいと思います。

たとえば、複数の取引を持つ口座番号のリストがあるワークシートがあります。これの隣に、私は空の各口座番号のワークシートがあります。 マクロを作成するたびに一致するレコードをコピーして貼り付けるのではなく、

私は以下のコードを見つけましたが、実際には複数のタブが作成されています。私はVBAの新機能です。タブを作成しないようにこのコードを適合させる方法はありますか？

大変助けになりました。

Sub parse_data() 
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 = 1 

Set ws = Sheets("Sheet1")  
lr = ws.Cells(ws.Rows.Count, vcol).End(xlUp).Row 
title = "A1:C1"   
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

これは、データを並べ替えしようとしているということですが、基本はあなたがシート1の行にデータをソートしていることであるように見えるものの例や説明もなく、本当に難しいですそのデータの値に応じていくつかの他のシートに分割したいと思っています。

以下は、これを達成する方法の簡単な例ですが、ソートしようとしている特定のデータとルールに採用する必要があります。

Sub Sort_Data(Has_Header As Boolean) 
    Dim Ws As Worksheet, New_Sht As Worksheet 
    Dim X As Integer, Cur_Row As Integer, Start_Row As Integer 
    Dim Shts() As Integer 
    ReDim Shts(1 to (Sheets.Count-1)) As Integer 
    For X = 1 to (Sheets.Count-1)) 
    Shts(X) = 1 
    If Has_Header = True the Shts(X) = 2 
    Next X 
    Set Ws = Sheets(1) 
    Start_Row = 1 
    If Has_Header = True then Start_Row = 2 
    For Cur_Row = Start_Row to Ws.Rows.Count 
    If Ws.Range("A1").Value = "" Then Exit For 'This checks for an empty row and quits the process once reaching one. 
    X = 0 
    Select Case Ws.Range(Cells(Cur_Row, 2).Address).Value 'This assumes the data you wish to sort by is in Column B (2). 
     Case "Value 1": 
     X = 2 
     Case "Value 2": 
     X = 3 
     Case "Value 3": 
     X = 4 
    End Select 
    If X <> 0 Then 
     Set New_Sht = Sheets(X) 
     Ws.Sheets.Range("A" & Cur_Row).EntireRow.Copy 
     New_Sht.Range("A" & Shts(X-1)).PasteSpecial xlPasteAll 
     Shts(X-1) = Shts(X-1) + 1 
    End If 
    Next Cur_Row 
End Sub