[ 初めての方へ | 一覧(最新更新順) | 全文検索 | 過去ログ ]
『データを項目別にシート分割（マクロ）がエラーとなる』（ヤッターマン）
下記のURLのマクロを既に作成しているExcelにシート追加して使いたいのですが、下記のようなエラーが出てしまいます。
「申し訳ございません。C:\Users\他の人のユーザー名\Downlods\data_sheets_divide_others.xlsm.が見つかりません。名前が変更されたか移動や削除が行われた可能性があります。」
https://excel-macro.com/data-sheets-divide/
上記のエラーをさせる為には何か方法はありますでしょうか。
URLのコードは下記となります。
ーーーーーーーーーーーーーーーーーーーーーーーーーーーーー
Sub data_sheets_divide()
Application.ScreenUpdating = False '画面更新非表示
Cells(2, 3).ClearContents
Cells(2, 4).ClearContents
'ダイアログからファイルを開く
FilePath = Application.GetOpenFilename
Pos = InStrRev(FilePath, "\") 'ファイル名の文字位置を検索
FileName = Mid(FilePath, Pos + 1) 'ファイル名の取得
If FilePath <> "False" Then
'ブックが開いているか確認してから開く
For Each wb In Workbooks
If wb.FullName = FilePath Then
Workbooks(FileName).Close '確認メッセージ表示させて閉じる
End If
Next wb
Workbooks.Open FilePath, ReadOnly:=True '読み取り専用で開く
Else
Exit Sub
End If
'ダイアログからシートを選択
Set ws = ShowSelectSheetDialog()
ws.Activate
Application.StatusBar = "処理中です..."
ws.Activate
Dim c As Integer '対象列用
'列取得
Dim s As String
Dim rng As Range
Do '列が決まるか中止するまでのループ
s = InputBox("項目名=(改行のみで終了)") '項目名取得
If s = "" Then Exit Sub '空白なら終了
Set rng = ws.Range(Cells(1, 1), Cells(1, Columns.Count)).Find(s, LookAt:=xlWhole) '項目名を1行目で探す
If Not rng Is Nothing Then Exit Do '見つけたら抜ける
MsgBox "項目名に[" & s & "]が見つかりません。"
Loop
If MsgBox("[" & rng.Value & "]で分けますか？", vbYesNo) <> vbYes Then Exit Sub '最終確認
Application.ScreenUpdating = False '画面更新非表示
c = rng.Column '対象列
'AdvancedFilterで指定列のデータの重複しない候補を取得(AC列を作業列とする)
Dim d As Variant
'AC列に作業列を挿入
Range("AC:AC").Insert
'指定列の重複しない値をAC列に作成
ws.Columns(c).AdvancedFilter Action:=xlFilterCopy, CopyToRange:=ws.Range("AC1"), Unique:=True
'AC列の値を配列に取得
d = ws.Range("AC1", ws.Range("AC" & Rows.Count).End(xlUp))
'AC列の作業列を削除
Range("AC:AC").Delete
'オートフィルタでシート別にコピー
Dim i As Integer
'指定列の重複しないデータを順に(1行目は見出しなので2行目から)(挿入位置の関係で最後から)
For i = UBound(d) To 2 Step -1
'シート追加(この時挿入したシートがActiveSheetになっている)
Sheets.Add After:=ws
'ActineSheet(挿入したシート)の名前を重複しないデータの注目データに設定
ActiveSheet.Name = d(i, 1)
'重複しないデータの注目データで対象列をオートフィルタ
ws.Cells.AutoFilter field:=c, Criteria1:=d(i, 1)
'オートフィルタで抽出した範囲をActineSheet(挿入したシート)のA1からにコピー
ws.AutoFilter.Range.Copy ActiveSheet.Range("A1")
Next
'対象シートのオートフィルタ解除(後始末)
ws.AutoFilterMode = False
ws.Select
ThisWorkbook.Sheets(1).Cells(2, 3) = ws.Name
ThisWorkbook.Sheets(1).Cells(2, 4) = FilePath
Application.StatusBar = False
Application.ScreenUpdating = True '画面更新表示
MsgBox "完了しました"
End Sub
' // シート選択ダイアログを表示
' // 戻り値： 選択されたシートオブジェクト
Public Function ShowSelectSheetDialog() As Worksheet
Dim ShBackup As Worksheet
Application.ScreenUpdating = False
Set ShBackup = ActiveSheet
With CommandBars.Add(Temporary:=True)
.Controls.Add(ID:=957).Execute
.Delete
End With
Set ShowSelectSheetDialog = ActiveSheet
ShBackup.Select
Application.ScreenUpdating = True
End Function
＜ 使用 Excel：Excel2016、使用 OS：Windows10 ＞
> For Each wb In Workbooks > If wb.FullName = FilePath Then
ここでブックの確認とかしているのだったら カウントとかすれば良いんじゃない？ （♀） 2023/02/25(土) 09:47:26
フォームコントロールに、他ブックのマクロを登録していて、 そのマクロが入っているブックを削除したか移動したか名前を変えたかって感じで マクロが見つからなくなってます （´・ω・`） 2023/02/25(土) 10:17:12
【エラー部分】
FilePath = Application.GetOpenFilename
Pos = InStrRev(FilePath, "\") '
こちらのマクロ（シート追加せずそのまま使用）で、データ分割後の2つの項目をセルに入力させたいのですが、そのようなコードご存じないでしょうか。
分割されたシートの特定の文字列の2行目の項目を抜き出したいです。
例：
分割後のシート1
A B C
1 商品ID 商品名 会社名
2 4005 モンブラン A会社
分割後のシート2
A B C
1 商品ID 商品名 会社名
2 4000 ショートケーキ B会社
上記の商品ID、商品名の2行目の文字列を抜き出しセルに入力する。
〜 F G
1 商品ID 商品名
2 4005 モンブラン
3 4000 ショートケーキ
（ヤッターマン） 2023/02/26(日) 06:02:07
ちょっとよくわかりません。追加の質問に入る前に、もう少し説明をしてもらえますか？
FilePath = Application.GetOpenFilename を実行するとファイルを選択する画面が出ると思いますが、 そこでどのような指定をしたのでしょうか？
変数の宣言とかはしない主義なんですか？ ダウンロードしたブックにあるマクロもそういう書き方なんでしょうか。
（abc） 2023/02/26(日) 08:08:29
FilePath = Application.GetOpenFilename
を実行するとファイルを選択する画面が出ると思いますが、 そこでどのような指定をしたのでしょうか？ 変数の宣言とかはしない主義なんですか？ ダウンロードしたブックにあるマクロもそういう書き方なんでしょうか →こちらダウンロードしたブックのマクロコードが上記のような内容となっておりました。 ファイルを選択する画面が出てくるので、そこで該当のExcelを選択してから、シートを選択し、項目名を入れると項目毎にシートが分かれるようになっております。
この分割した項目名（今回は商品ID）と商品名に紐づく情報をシートに記載できればと思っております。
また、出来れば分割対象（元データ）の2行名からをカウントし対象数やシート数の情報も出せればと思うのですが、やり方が良く分からず…
（ヤッターマン） 2023/02/26(日) 19:56:22
（abc） 2023/02/26(日) 21:41:58
[ 一覧(最新更新順) ]
YukiWiki 1.6.7 Copyright (C) 2000,2001 by Hiroshi Yuki.
Modified by kazu.