この質問に答える前に、あなたが達成しようとしていると私が信じていることを書きたいと思います。これがあなたがやろうとしていることであると確認したら、それを達成するためのコードを動作させる手助けをしようとします。これは通常コメントで行われますが、これまでのコメントのスレッドは少しバラバラで、コードは非常に複雑です...
- シートにデータがあります（「sheet1」と呼ばれます-それは別のものかもしれません）
- 最初の列には、繰り返される可能性のある特定の値が含まれています
- いくつの列があるかわかりません...でもそれを知りたいです
- 列 A で一意の値 (「キー値」と呼びます) を見つけて、メッセージ ボックスに (一度に 1 つずつ) 表示しようとします。これは、最終的なプログラムの実際の機能というよりも、デバッグ ステップのように見えます。
- 次に、列 A でオートフィルターをオンにします。特定の値に一致する行のみを選択する
- シートの名前と同じ値を使用して、そのようなシートが存在するかどうかを確認します。存在する場合は、その内容をクリアします。そうでない場合は、ワークブックの最後に作成します (キーの名前を付けます)。
- シート 1 の列 A で同じ (キー) 値を持つすべての行を選択し、フィルター処理した列 A の値と同じ名前のシートにそれらをコピーします。
- 列 A の一意の (キー) 値ごとに手順 5 ～ 8 を繰り返します。
- すべてが完了すると、列 A のキー値よりも (少なくとも) 1 つ多いシートがあると思います (最初のデータシートもあります)。ただし、「余分な」シート (他の名前のシート) は削除しません。各シートには、シート 1 の現在の内容に対応するデータ行のみが含まれます (以前のデータは削除されています)。
- 操作中に、オートフィルタリングのオンとオフを切り替えます。自動フィルターを無効にして終了したい。
これが本当にあなたがやろうとしていることであることを確認してください。列 A の値の形式を教えていただけると助かります。いくつかのことは、あなたが現在行っているよりも効率的に行うことができるのではないかと思います. 最後に、この方法でデータを整理する全体的な目的は、データを特定の方法で整理し、さらに計算/グラフなどを実行することであるかどうか疑問に思います。Excel (VBA) には、作成するためのあらゆる種類の関数が組み込まれています。データ抽出の作業がより簡単になります。特定の作業を完了するために、この種のデータの再配置が必要になることはめったにありません。その点についてコメントをいただければ...
次のコードは、上記のすべてを実行します。特定のタスク ( 、、および) を処理するためのFor Each、および関数/サブルーチンの使用に注意してください。これにより、トップレベルのコードが読みやすく理解しやすくなります。また、エラー トラップは、ワークシートが存在するかどうかを確認する小さなセクションに限定されていることに注意してください。私にとっては、問題なく実行されました。エラーが発生した場合は、ワークシートの内容が影響する可能性があるため、ワークシートの内容をお知らせください (たとえば、列のセルにシート名で許可されていない文字が含まれている場合など)。また、コードが「達成しようとしているものによっては、「UsedRange」の方が良いかもしれません...uniquecreateOrClearworksheetExistsA/\!
Option Explicit
Sub Solution()
Dim shData As Worksheet
Dim nameRange As Range
Dim r As Range, c As Range, A1c As Range, s As String
Dim uniqueNames As Variant, v As Variant
Set shData = Sheets("Sheet1") ' sheet with source data
Set A1c = shData.[A1] ' first cell of data range - referred to a lot...
Set nameRange = Range(A1c, A1c.End(xlDown)) ' find all the contiguous cells in the range
' find the unique values: using custom function
' omit second parameter to suppress dialog
uniqueNames = unique(nameRange, True)
Application.ScreenUpdating = False ' no need for flashing screen...
' check if sheet with each name exists, or create it:
createOrClear uniqueNames
' filter on each value in turn, and copy to corresponding sheet:
For Each v In uniqueNames
A1c.AutoFilter Field:=1, Criteria1:=v, _
Operator:=xlAnd
A1c.CurrentRegion.Copy Sheets(v).[A1]
Next v
' turn auto filter off
A1c.AutoFilter
' and screen updating on
Application.ScreenUpdating = True
End Sub
Function unique(r As Range, Optional show)
' return a variant array containing unique values in range
' optionally present dialog with values found
' inspired by http://stackoverflow.com/questions/3017852/vba-get-unique-values-from-array
Dim d As Object
Dim c As Range
Dim s As String
Dim v As Variant
If IsMissing(show) Then show = False
Set d = CreateObject("Scripting.Dictionary")
' dictionary object will create unique keys
' have to make it case-insensitive
' as sheet names and autofilter are case insensitive
For Each c In r
d(LCase("" & c.Value)) = c.Value
Next c
' the Keys() contain unique values:
unique = d.Keys()
' optionally, show results:
If show Then
' for debug, show the list of unique elements:
s = ""
For Each v In d.Keys
s = s & vbNewLine & v
Next v
MsgBox "unique elements: " & s
End If
End Function
Sub createOrClear(names)
Dim n As Variant
Dim s As String
Dim NewSheet As Worksheet
' loop through list: add new sheets, or delete content
For Each n In names
s = "" & n ' convert to string
If worksheetExists(s) Then
Sheets(s).[A1].CurrentRegion.Clear ' UsedRange might be better...?
Else
With ActiveWorkbook.Sheets
Set NewSheet = .Add(after:=Sheets(.Count))
NewSheet.Name = s
End With
End If
Next n
End Sub
Function worksheetExists(wsName)
' adapted from http://www.mrexcel.com/forum/excel-questions/3228-visual-basic-applications-check-if-worksheet-exists.html
worksheetExists = False
On Error Resume Next
worksheetExists = (Sheets(wsName).Name <> "")
On Error GoTo 0
End Function