0
このコードでは、データをコピーして、名前が属する適切な対応するタブに貼り付けますが、次のデータセットのために再度実行すると、最後のデータ。私は最終的には）次の空行に上記のコードでは次の空白に情報を貼り付ける必要があります
Dim c As Range, namesRng As Range
Dim name As Variant
With Worksheets("DRIVERS") '<--| reference "DRIVERS" worskheet
Set namesRng = .Range("A2", .Cells(.Rows.Count, "a").End(xlUp)) '<--| set the range of "drivers" in column "a" starting from row 4 down to last not empty row
End With
With CreateObject("Scripting.Dictionary") '<--| instance a 'Dictionary' object
For Each c In namesRng.SpecialCells(xlCellTypeConstants, xlTextValues) '<--| loop through "drivers" range cells with text content only
.Item(c.Value) = c.Value '<--| build the unique list of names using dictionary key
Next
Set namesRng = namesRng.Resize(namesRng.Rows.Count + 1).Offset(-1) '<--| resize the range of "names" to have a "header" cell (not a name to filter on) in the first row
For Each name In .Keys '<--| loop through dictionary keys, i.e. the unique names list
FilterNameAndCopyToWorksheet namesRng, name '<--| filter on current name and copy to corresponding worksheet
Next
End With '<--| release the 'Dictionary' object
End Sub
Sub FilterNameAndCopyToWorksheet(rangeToFilter As Range, nameToFilter As Variant)
Dim destsht As Worksheet
Set destsht = Worksheets(nameToFilter) '<--| set the worksheet object corresponding to passed name
With rangeToFilter
.AutoFilter Field:=1, Criteria1:=nameToFilter
Intersect(.Parent.UsedRange, .Resize(.Rows.Count - 1).Offset(1).SpecialCells(xlCellTypeVisible).EntireRow).Copy destsht.Cells(destsht.Rows.Count, "a").End(xlUp)
.Parent.AutoFilterMode = False
End With
End Sub
コード関連の質問をするときは、使用している特定の言語のタグを追加することをおすすめします。 * copy *と* paste *は自分ではほとんど役に立たない。あなたの質問に適切な言語タグ（excel-vba、それが表示されます）を含めるには[編集]してください。また、あなたが投稿したコードがあなたのために働いていないことについても説明してください。今読んでいるように、私は*私のコードを書いてください。私たちはコード作成サービスではありません。ありがとう。 –
申し訳ありませんが、ケンはフォーラムで初めて質問しました。私は虫を訂正します –
問題ありません。しかし、アドバイスの言葉 - これはフォーラムではなく、人々はそれを1つと呼ぶときにそれを気に入らない。 *フォーラム*は議論を伴うソーシャルサイトを意味し、これはまったくそのようなサイトではありません。これは厳密にはQ＆Aサイトです。あなたは[ツアー]を取って[ヘルプ]ページを読んで時間を過ごすことができます。 –