[ 初めての方へ | 一覧(最新更新順) | 全文検索 | 過去ログ ]
『マクロ実行時エラーについて』（砂糖）
初めまして、マクロ全くの初心者です。
よろしくお願いいたします。
ブックAから複数条件の合うものを検索してブックBにコピー貼り付けをしたいのですが、実行時に「インデックスに有効範囲がありません」というエラーが出てしまいます。
以下使用しているVBAです。
Sub Copy2Book()
Dim val() As Variant
Const bk1Name As String = "9月まとめテスト.xlsm" 'コピー元ブック名
Const sh1Name As String = "Sheet1" 'コピー元シート名
Const colVal1 As String = "A" 'コピー元「契約日」列番号
Const colVal2 As String = "B" 'コピー元「お客様名」列番号
Const colVal3 As String = "F" 'コピー元「売上金額」列番号
Const colKey As String = "D" 'コピー元「担当1」列番号
Const ro1St As Integer = 2 'コピー元データ開始行番号
Const bk2Name As String = "報酬明細 南テスト.xlsm" 'コピー先ブック名
Const sh2Name As String = "田中" 'コピー先シート名
Const colOut As String = "A" 'コピー先出力開始列番号
Const ro2St As Integer = 29 'コピー先出力開始行番号
Const strKy = "田中" 'キー文字列（条件（colKey））
Dim sh1 As Worksheet, sh2 As Worksheet
Dim roEnd As Long, i As Long
Set sh1 = Workbooks(bk1Name).Worksheets(sh1Name)
Set sh2 = Workbooks(bk2Name).Worksheets(sh2Name)
roEnd = sh1.Cells(Rows.Count, colKey).End(xlUp).Row
ReDim val(1, 0)
n = 0
For i = ro1St To roEnd
If sh1.Cells(i, colKey) = strKy Then
If UBound(val, 3) < n Then ReDim Preserve val(1, n)
val(0, n) = sh1.Cells(i, colVal1).Value
val(1, n) = sh1.Cells(i, colVal2).Value
val(2, n) = sh1.Cells(i, colVal3).Value
n = n + 1
End If
Next i
sh2.Cells(ro2St, colOut).Resize(n, 2) = WorksheetFunction.Transpose(val)
sh2.Activate
End Sub
よろしくお願いいたします。
＜ 使用 Excel：Excel2016、使用 OS：Windows10 ＞
（隠居じーさん） 2018/10/08(月) 12:48
コードは黄色くならなかったです。
ちなみにエラー番号は「9」でした。
ブックAは「sheet1」にしっかりとコピー元を入れてあります。
コピー先であるブックBは「sheet2」を「田中」に名前変更してあります。
（砂糖） 2018/10/08(月) 14:25
失礼いたしました。 二元配列の操作に問題があるかもせれません。（最終次元しかRedimできなさそぉなきが） ＾＾； ReDim val(3, 0)
↑
ここ
n = 0
For i = ro1St To roEnd
If sh1.Cells(i, colKey) = strKy Then
If UBound(val, 2) < n Then ReDim Preserve val(3, n)
↑ ↑
ここ ここ
と最後の書き出し部分
Resize(n, 3)
↑
ここ
変えてみてはどうでしょうか。
（隠居じーさん） 2018/10/08(月) 14:44
Sub Copy2Book()
Dim val() As Variant
Const bk1Name As String = "9月まとめテスト.xlsm" 'コピー元ブック名
Const sh1Name As String = "Sheet1" 'コピー元シート名
Const colVal1 As String = "A" 'コピー元「契約日」列番号
Const colVal2 As String = "B" 'コピー元「お客様名」列番号
Const colVal3 As String = "F" 'コピー元「売上金額」列番号
Const colKey As String = "D" 'コピー元「担当1」列番号
Const ro1St As Integer = 2 'コピー元データ開始行番号
Const bk2Name As String = "報酬明細 南テスト.xlsm" 'コピー先ブック名
Const sh2Name As String = "千葉 (2)" 'コピー先シート名
Const colOut As String = "A" 'コピー先出力開始列番号
Const ro2St As Integer = 29 'コピー先出力開始行番号
Const strKy = "千葉(西村)" 'キー文字列（条件（colKey））
Dim sh1 As Worksheet, sh2 As Worksheet
Dim roEnd As Long, i As Long
Set sh1 = Workbooks(bk1Name).Worksheets(sh1Name)
Set sh2 = Workbooks(bk2Name).Worksheets(sh2Name)
roEnd = sh1.Cells(Rows.Count, colKey).End(xlUp).Row
ReDim val(3, 0)
n = 0
For i = ro1St To roEnd
If sh1.Cells(i, colKey) = strKy Then
If UBound(val, 2) < n Then ReDim Preserve val(3, n)
val(0, n) = sh1.Cells(i, colVal1).Value
val(1, n) = sh1.Cells(i, colVal2).Value
val(2, n) = sh1.Cells(i, colVal3).Value
n = n + 1
End If
Next i
sh2.Cells(ro2St, colOut).Resize(n, 3) = WorksheetFunction.Transpose(val)
sh2.Activate
End Sub
というふうに早速変えてみたのですが、やはり同じエラーが出てしまいます。
（砂糖） 2018/10/08(月) 15:03
追伸、忘れていました ＾＾； コピー先BOOKを開かないとだめだと思います。（というか、開いた方が簡単です ＾＾；）
同じフォルダ内に双方のＢＯＯＫが有ることが前程です。 違うならパスを変更してください。 ここでの記入ミスだとは思いますが ｎ 変数定義無しでエラーです。 変更後保存して閉じてくださいね。 下記で動いています。何かの足しにでも。
Option Explicit
Sub Copy2Book_LEV1()
Dim n As Long, WB As Workbook
Dim val() As Variant
Const bk1Name As String = "9月まとめテスト.xlsm" 'コピー元ブック名
Const sh1Name As String = "Sheet1" 'コピー元シート名
Const colVal1 As String = "A" 'コピー元「契約日」列番号
Const colVal2 As String = "B" 'コピー元「お客様名」列番号
Const colVal3 As String = "F" 'コピー元「売上金額」列番号
Const colKey As String = "D" 'コピー元「担当1」列番号
Const ro1St As Integer = 2 'コピー元データ開始行番号
Const bk2Name As String = "報酬明細 南テスト.xlsm" 'コピー先ブック名
Const sh2Name As String = "田中" 'コピー先シート名
Const colOut As String = "A" 'コピー先出力開始列番号
Const ro2St As Integer = 29 'コピー先出力開始行番号
Const strKy = "田中" 'キー文字列（条件（colKey））
Dim sh1 As Worksheet, sh2 As Worksheet
Dim roEnd As Long, i As Long
Set sh1 = Workbooks(bk1Name).Worksheets(sh1Name)
ChDir ThisWorkbook.Path
Set WB = Workbooks.Open(bk2Name)
Set sh2 = Workbooks(bk2Name).Worksheets(sh2Name)
roEnd = sh1.Cells(Rows.Count, colKey).End(xlUp).Row
ReDim val(3, 0)
n = 0
For i = ro1St To roEnd
If sh1.Cells(i, colKey) = strKy Then
If UBound(val, 2) < n Then ReDim Preserve val(3, n)
val(0, n) = sh1.Cells(i, colVal1).Value
val(1, n) = sh1.Cells(i, colVal2).Value
val(2, n) = sh1.Cells(i, colVal3).Value
n = n + 1
End If
Next i
sh2.Cells(ro2St, colOut).Resize(n, 3) = WorksheetFunction.Transpose(val)
sh2.Activate
WB.Close True
End Sub
（隠居じーさん） 2018/10/08(月) 15:19
定数を多用していてかえって見づらくなっていると思いますし、
＞マクロ全くの初心者です。
とおっしゃっているので、一度配列のことは忘れて、もともとの設計から
再考してみて単純にコピペで解決できないか考えてみてはどうでしょうか？
研究のコードを提供します。
Sub Copy2Book改()
Dim srcSH As Worksheet, dstSH As Worksheet
Dim i As Long
Stop 'ブレークポイントの代わり
Set srcSH = Workbooks("9月まとめテスト.xlsm").Worksheets("Sheet1")
Set dstSH = Workbooks("報酬明細 南テスト.xlsm").Worksheets("田中")
With srcSH
For i = 2 To .Cells(.Rows.Count, "D").End(xlUp).Row
If .Cells(i, "D") = "田中" Then
'「契約日」=A / 「お客様名」=B / 「売上金額」=F
Union(.Cells(i, "A"), .Cells(i, "B"), .Cells(i, "F")).Copy dstSH.Cells(29, "A")
Exit For
End If
Next i
End With
Application.Goto dstSH.Range("A29")
End Sub
（もこな２） 2018/10/08(月) 16:23
(途中で検索キーとシート名が変わったのも気になりますが…)
（もこな２） 2018/10/09(火) 08:41
恐れ入りますが、再度教えていただきたく思います。
よろしくお願いいたします。
（砂糖） 2018/10/09(火) 14:19
こんにちは ＾＾ ＞＞いくつかではなく、検索して条件に合ったもの全てを貼り付けたいです。 え～と。。。 何をどの様に検索してどれを、何処に貼り付けるのか。。。さらに詳しく教えていただくと多数回答があるかもです。
同じパターンならば（シリアル、数値、式、文字列、オブジェクト等）情報はもちろんダミーで結構です コードから推測だけでは解りづらいので。 いま、わかっているのは報酬明細 南テストの田中シートの A29以降に３列にわたり、日付の違う行数分の田中さんの情報を書き込む。。。でしたかね？
読込、書込み（結果）のフォーマットをお願いします。 。。。もこな２さんの推測のように 報酬明細 南テスト、にた～くさん人員別シートがあって、 9月まとめテストのなかから、名前別に全情報を振り分けコピー（行単位） とかなのでせうか。 お！ひょっとして BOOK別なのでしょうか ＾＾
（隠居じーさん） 2018/10/09(火) 16:23
コピー元：ブック名「9月まとめ」 シート名「sheet1」
A B C D E F G H
1 契約日 お客様名 工事内容 担当1 担当2 請負金額 備考1 備考2
2 2018/9/13 山田一郎 屋根工事、板金工事等 斉藤 高橋 1,000,000 文字 ％
3 2018/9/16 田中邦江 屋根工事、雨樋工事等 上野 中村 1,150,000 ％ 文字
4 2018/9/23 鈴木太郎 外壁塗装工事、付帯部塗装等 渡辺 木村 1,000,000 空白 空白
以下100行以上続く
コピー先：ブック名「報酬明細書 南」 シート名「千葉（2）」
A B C D E F G
1 空白 題名
2 空白 空白
3 空白 契約日 お客様名 売上金額 他項目名 他項目名 備考
4 空白 小題名1「もじ」
5 空白 2018/9/16 田中邦江 1,150,000 空白 空白 空白
以下20行以上続く
↑は検索条件が上野の場合です。
検索条件は担当1の斉藤だったり、担当2の高橋だったりします。
という感じです。
分かりにくく申し訳ございません。
よろしくお願いいたします。
（砂糖） 2018/10/09(火) 17:10
（隠居じーさん） 2018/10/09(火) 18:05
たとえば、先に貼り付けたところの1行下に貼り付けるとかであれば、研究用に提供したコードを少し加工するだけではないでしょうか？
･条件に合うものが見つかってもループを抜けない
･貼り付けしたら(条件に合うものが見つかったら)、出力行に1足す
ではどうでしょう。
（もこな２） 2018/10/09(火) 19:45
______A___________B___________C_____________D______E______F_______G_____H___ 1 契約日 お客様名 工事内容 担当1 担当2 請負金額 備考1 備考2 2 2018/9/13 山田一郎 屋根工事 上野 高橋 1,000,000 文字 ％ 3 2018/9/16 田中邦江 屋根工事 木村 中村 1,150,000 ％ 文字 4 2018/9/23 鈴木太郎 外壁塗装工事 渡辺 上野 1,000,000 空白 空白
【コピー先：ブック名「報酬明細書 南」 シート名「千葉（2）」】
___A_____B____________________C_______D_________E________F_______G___ 1 空白 題名 2 空白 空白 3 空白 契約日 お客様名 請負金額 他項目名 他項目名 備考 4 空白 小題名1「もじ」 5 空白 2018/9/13 山田一郎 1,000,000 空白 空白 空白 6 空白 2018/9/23 鈴木太郎 1,000,000 空白 空白 空白
こんな感じで、担当が”上野”さんだったら対応するシートの5行目以降に特定セルをコピーしたいってことなんじゃないですか？
（もこな２） 2018/10/10(水) 07:48
Sub 研究用_弐()
Dim dstSH As Worksheet
Dim i As Long, c As Long
Const 検索キーワード As String = "上野"
Const 出力シート名 As String = "千葉（2）"
Stop 'ブレークポイントの代わり
Set dstSH = Workbooks("報酬明細 南テスト.xlsm").Worksheets(出力シート名)
With Workbooks("9月まとめテスト.xlsm").Worksheets("Sheet1")
For i = 2 To .Cells(.Rows.Count, "D").End(xlUp).Row
If .Cells(i, "D").Value = 検索キーワード Or .Cells(i, "E").Value = 検索キーワード Then
'「契約日」=A / 「お客様名」=B / 「"請負"金額」=F
Union(.Cells(i, "A"), .Cells(i, "B"), .Cells(i, "F")).Copy dstSH.Cells(5 + c, "B")
c = c + 1
End If
Next i
End With
End Sub
研究用に提供しますので、「検索キーワード」「出力シート名」を可変にするようにするにはどうしたらいいか考えてみてはどうでしょうか？
（出力したいイメージが推測通りであればですが・・・）
（もこな２） 2018/10/10(水) 12:59
検索条件は【千葉】です。
ちなみに上野、木村、野村、中村というように人ごとにタブを分けております。
コピー元の「9月まとめ」は毎月データ量が変わります。
多いときは100件以上になることもあります。
【コピー元：ブック名「9月まとめ」 シート名「sheet1」】
______A___________B___________C_____________D______E______F_______G_________H___
1 契約日 お客様名 工事内容 担当1 担当2 請負金額 備考1 備考2 2 2018/9/13 山田一郎 屋根工事 上野 高橋 1,000,000 ％ 空白 3 2018/9/16 田中邦江 屋根工事 木村 中村 1,150,000 132,000 ％ 4 2018/9/23 鈴木太郎 外壁塗装工事 千葉 上野 1,000,000 空白 空白 5 2018/9/4 武田敦志 雨樋・瓦工事 千葉 千葉 1,120,000 200,000 雨樋 6 2018/9/12 杉田誠人 外壁塗装工事 千葉 千葉 1,010,000 空白 空白 7 2018/9/13 柴田洋子 屋根工事 野村 千葉 1,000,000 ％ 空白 8 2018/9/24 小川弘美 屋根工事 木村 千葉 954,000 ％ 空白
【コピー先：ブック名「報酬明細書 南」 シート名「千葉（2）」】
___A_____B____________________C_______D_________E________F_______G___ 1 空白 題名 2 空白 空白 3 空白 契約日 お客様名 請負金額 他項目名 他項目名 備考 4 空白 小題名1「受付」 5 空白 2018/9/24 小川博美 954,000 空白 空白 空白 6 空白 該当が他にない場合以降は空白 7 空白 8 空白 9 空白 空白 10空白 空白 11空白 小題名2「受付と打合せ」 12空白 2018/9/4 武田敦志 1,120,000 空白 空白 雨樋 13空白 2018/9/12 杉田誠人 1,010,000 空白 空白 空白 14空白 該当が他にない場合以降は空白 15空白 16空白 17空白 小題名3「打合せ」 18空白 2018/9/23 鈴木太郎 1,000,000 空白 空白 空白 19空白 該当が他にない場合以降は空白 20空白 21空白 小題名3「その他」 22空白 2018/9/4 武田敦志 200,000 空白 空白 雨樋 23空白 2018/9/13 柴田洋子 1,000,000 空白 空白 ％
何度も申し訳ございません。
再度ご返信いただければ幸いです。
（砂糖） 2018/10/11(木) 12:27
こんにちは ＾＾ ご返信いただいた内容だと取込項目はあまり変化が無かったように思いますが VBAはかなり研究されておられるようなので｡下記の様な物を作ってみました｡
二次元配列の替わりに連想配列ディクショナリーを使ってみました｡ 回答ではありませんが､何かの足しにでもなれば幸甚です｡ 間違っているかもしれません。必ずバックアップしてお試しください。 ＾＾；
＞＞小題名3「打合せ」。。。等の各、小題の挿入のタイミング、と判定基準 など付け足すと応用は出来るかもしれませんね｡ もこな2さんのコード等も参考になさり､組みなおしてみて お困りの箇所は又､ご質問頂くと､多数の回答があると思います｡
Option Explicit
Sub main()
Dim tanto, rr As Range, r As Range
Dim D, sh1 As Worksheet
Dim lr As Long, i As Long, buf, y As Long
Set D = CreateObject("Scripting.Dictionary")
Set sh1 = Workbooks("9月まとめテスト.xlsm").Worksheets("Sheet1")
Set rr = sh1.Range("A1").CurrentRegion
tanto = Application.InputBox("担当者の姓名を入力してください。", "Excel-VBA", "上野", , , , , 2)
If VarType(tanto) = vbBoolean Then Exit Sub
Set r = Union(rr.Columns(4), rr.Columns(5)).Find(what:=tanto, LookIn:=xlValues, lookat:=xlWhole)
If r Is Nothing Then
MsgBox "当該担当者の情報は有りません。" & vbLf & vbLf & tanto, vbCritical
Exit Sub
End If
Workbooks.Add
With ActiveSheet
.Cells(1, 2) = "題 名"
.Cells(3, 2).Resize(1, 6) = Array("契約日", "お客様名", "売上金額", "他項目名", "他項目名", "備考")
.Cells(4, 2) = "小題名1「もじ」"
lr = sh1.Cells(sh1.Rows.Count, 4).End(xlUp).Row
For i = 2 To lr
If sh1.Cells(i, 4) = tanto Or sh1.Cells(i, 5) = tanto Then
D(i) = Array(sh1.Cells(i, 1).Value, sh1.Cells(i, 2).Value, sh1.Cells(i, 6).Value)
End If
Next i: y = 5
For Each buf In D.items
.Cells(y, 2).NumberFormatLocal = "yyyy/mm/dd"
.Cells(y, 4).NumberFormatLocal = "#,###"
.Cells(y, 2).Resize(1, 3) = buf
y = y + 1
Next
.UsedRange.Rows(5).EntireColumn.AutoFit
End With
End Sub
（隠居じーさん） 2018/10/11(木) 14:54
連想配列というものは初めて聞いた単語なので、このコードを理解するのに時間がかかりそうです・・・。
調べつつ色々試してみようと思います！
どうしても難しい場合は、またこちらで質問をさせていただきます。
本当にありがとうございます。
（砂糖） 2018/10/11(木) 17:14
ただ、私は説明できるくらいに理解できてるとは言いがたいので、もし解説を希望される他の回答者さんにお任せです。
さて、Dictionaryオブジェクト以外で気になった点ですが、隠居じーさんさんもコメントされておりますが、どういう条件で”小題名～”をB列に入れるのかが質問文から読み取れませんし、そもそも、どれが「受付」でどれが「受付と打合せ」・・・というように、元々のレコードの何を見て振り分けているかの説明がないと回答者もExcel君も解りません。
また、「該当が他にない場合以降は空白」とさらっと書いてますけど、空白行を”一定行入れて”次の小題名を出力したいのか、小題名を出力する行は決まっていて、そこまでは空白行という意味なのかよくわかりません。
さらに言えば、そもそもやりたいこと（知りたいこと）がなんなのかよくわかりません。
具体的には、
＞コピー元の「9月まとめ」は毎月データ量が変わります。
＞多いときは100件以上になることもあります。
とのことですが、これはなんか困ってるんでしょうか？現状コードでも最終行を調べてそこまで処理をするようになっているので、10件だろうと10万件だろうと同じコードで対応できますよね？
（もっとも現状のループを使った「条件判定・総当たり方式」だと10万件もあったら遅くてイライラしそうなので、そういった観点で別の方法で処理できないかを聞きたいのでしょうか？）
または、
＞ちなみに上野、木村、野村、中村というように人ごとにタブを分けております。
といっているので、推測するに、人ごとにシートを分けてあって、まとめシートから、それぞれのシートに振り分けコピーしたいといったことと推測すると、「研究用_弐」を提供したときに、書き添えたように「検索キーワード」「出力シート名」を可変にするようにするにはどうしたらいいか考えてみてはどうでしょうか？
（もこな２） 2018/10/11(木) 19:21
・契約日やお客様名等の項目名と各小題名はコピー先である「報酬明細書 南」に既に手入力されているものです
ちなみに小題名が入力されている行はB～Gまでセルの結合をしてあります。
・「受付」はコピー元「担当2」を見て振り分けています。
・「受付と打合せ」はコピー元「担当1」と「担当2」を見て振り分けています。
・「打合せ」はコピー元「担当1」を見て振り分けています。
・「該当がない場合以降は空白」はその後5～10行空白が続きます。該当件数が多かった場合に備えての空白です。
・予備の空白が何行か続いたのち、次の小題名が入っています。
・「コピー元の「9月まとめ」は毎月データ量が変わります。」「多いときは100件以上になることもあります。」は申し訳ございません。まだ私が完璧にコードを読むことができていないため、最終行まで処理できると分からず聞いてしまいました。
説明があまりうまくできませんので、ダミー情報を作成してみました。
http://firestorage.jp/download/5386c07246784c7a2e75508add28563ccbbf1234
私の拙い説明にご丁寧返信いただきましてありがとうございます。
（砂糖） 2018/10/12(金) 11:32
＞説明があまりうまくできませんので、ダミー情報を作成してみました。
よくわからないリンクを踏む気がないので見てません。
＞契約日やお客様名等の項目名と各小題名はコピー先である「報酬明細書 南」に既に手入力されているものです
＞該当がない場合以降は空白」はその後5～10行空白が続きます。該当件数が多かった場合に備えての空白です。
なるほど、小課題の行と項目行は決め打ちなんですね。
そうなると該当がなかった場合に空白を入れるじゃなくて、該当の出力枠？に順番に貼り付けていけばいいですね。
（ただ、元データが100件を超える～といいつつ、出力枠？が数行程度だと、出力枠を超えるほど該当したらどうするでしょう？）
＞・「コピー元の「9月まとめ」は毎月データ量が変わります。」「多いときは100件以上になることもあります。」は申し訳ございません。まだ私が完璧にコードを読むことができていないため、最終行まで処理できると分からず聞いてしまいました。
元コードの
roEnd = sh1.Cells(Rows.Count, colKey).End(xlUp).Row For i = ro1St To roEnd
は理解できてますか？
＞・「受付」はコピー元「担当2」を見て振り分けています。
＞・「受付と打合せ」はコピー元「担当1」と「担当2」を見て振り分けています。
＞・「打合せ」はコピー元「担当1」を見て振り分けています。
そうなると、
「担当1」に該当する名前があったとき→「受付」「受付と打合せ」の出力枠の最終行+1に貼り付け
「担当2」に該当する名前があったとき→「受付と打合せ」「打合せ」の出力枠の最終行+1に貼り付け
とすればよいですね。
（貼付けられる順番にこだわりがなければ、オートフィルタなどで抽出して一気に貼り付けでも可）
（もこな２） 2018/10/12(金) 12:30
___A_____B_________________C_________D_________E________F_______G___ 1 題名 2 3 小題名1「受付」 4 契約日 お客様名 請負金額 他項目名 他項目名 備考 5 2018/9/24 小川博美 954,000 6 7 8 9 10 11 小題名2「受付と打合せ」 12 契約日 お客様名 請負金額 他項目名 他項目名 備考 13 2018/9/4 武田敦志 1,120,000 雨樋 14 2018/9/12 杉田誠人 1,010,000 15 16 17 18 小題名3「打合せ」 19 契約日 お客様名 請負金額 他項目名 他項目名 備考 20 2018/9/23 鈴木太郎 1,000,000 21 22 23 小題名3「その他」 24 契約日 お客様名 請負金額 他項目名 他項目名 備考 25 2018/9/4 武田敦志 200,000 雨樋 26 2018/9/13 柴田洋子 1,000,000 ％
あと、表を整理しなおしてみての疑問ですが「その他」に振り分ける条件とは？
（もこな２） 2018/10/12(金) 13:02
・リンクの件申し訳ございません。
一応リンク先はオンラインストレージです。
・元データは今のところ100件以上500件未満です。
元データ量は多いのですが。担当ごとに分ける→小項目ごとに分けるとやると、一つの小項目の該当数が20～50程になります。
9月まとめを作成している段階で、コピー先の小項目の行数が足りないと感じた時点で小項目の行数を手動で増やしています。
・最終行処理コードがこの部分だと分かっていませんでした。
教えていただきありがとうございます。
roEnd = sh1.Cells(Rows.Count, colKey).End(xlUp).Row For i = ro1St To roEndこのコードについてネットで調べ理解できました。
・「打合せ」とうの振り分けについて
担当1にのみ該当する名前があった場合はコピー先の「打合せ」に振り分けられます。
担当2にのみ該当する名前があった場合はコピー先の「受付」に振り分けられます。
担当1と担当2の両方に該当の名前があった場合はコピー先の「受付と打合せ」に振り分けられます。
・その他への振り分け条件について
コピー元の備考1と備考2のどちらかに金額、文字、％のどれかが入っているものが振り分けられます。
コピー元の備考1に金額は入っていた場合はコピー先「その他」の請負金額にその金額、備考に％または文字が入ります。
コピー元の備考1に％、備考2は空白の場合はコピー先「その他」の請負金額コピー元の請負金額がそのままコピー先の請負金額が入り、コピー先の備考に％が入ります。
コピー元の備考1に文字、備考2は空白の場合も同様です。
オートフィルタについても考えました。
他のデータで条件に該当するものを抽出→条件に合わせて金額自動表示というものです。
社内でしか使用しない・私しか使用しないデータなのでそちらはオートフィルタで対応したのですが、今回のデータは使用するのが私だけでなく、社外の人間も使用いたします。
そして、社外の人間にオートフィルタでは次の作業に支障がでると言われてしまっています。
ちなみに私はその次の作業がどのようなものなのか知る権利をいただいておりません。
なので、今回のデータは該当条件をオートフィルタではなくコピーで作成したいと思っています。
（砂糖） 2018/10/12(金) 14:39
＞＞7 2018/9/13 柴田洋子 屋根工事 野村 千葉 1,000,000 ％ 空白
＞＞8 2018/9/24 小川弘美 屋根工事 木村 千葉 954,000 ％ 空白
（砂糖） 2018/10/11(木) 12:27
の情報によれば
小川弘美 様 分は ％ 表示があるので 受付 では 無く。その他。。。なのでは。
あと同情報で
受付と打ち合わせ
2018/9/4 武田敦志 1,120,000 空白 空白 雨樋
その他
2018/9/4 武田敦志 200,000 空白 空白 雨樋
は備考1に金額が有った場合は
一行に二件分のデータが有るのでしょうか ＾＾；
１．請負金額で。。。受付、受付と打ち合わせ、打ち合わせのいづれかで書込み
２．備考1の金額でその他に書き込み。。。
気が付いた点だけですみません。。。何かその辺の条件がすっきりすれば、多数の方から
アドバイスがあるかもと思いアップしました。
でわ ＾＾
（隠居じーさん） 2018/10/17(水) 14:02
私は↓のように思ったんですが、提示例と合わないし正直よくわからんです。
条件１：D列（担当1）が「千葉」、E列（担当2）が「千葉」以外 → 小題名1「受付」
条件２：D列（担当1）が「千葉」、E列（担当2）も「千葉」 →小題名2「受付と打合せ」
条件３：D列（担当1）が「千葉」以外、E列（担当2）が「千葉」 →小題名3「打合せ」
条件４：上記条件を満たさない、つまり、D列（担当1）、E列（担当2）ともに「千葉」以外
かつ G列（備考1）、H列（備考2）の両方あるいはどちらかに"何か"入力されている
→小題名3「その他」
（もこな２） 2018/10/17(水) 20:35
読込情報。。。最後の小川様の備考1の1％を消す （砂糖さん2018/10/11(木) 12:27表示との相違点）
A B C D E F G H
1 契約日 お客様名 工事内容 担当1 担当2 請負金額 備考1 備考2
2 2018/9/13 山田一郎 屋根工事 上野 高橋 1,000,000 1%
3 2018/9/16 田中邦江 屋根工事 木村 中村 1,150,000 132,000 2%
4 2018/9/23 鈴木太郎 外壁塗装工事 千葉 上野 1,000,000
5 2018/9/4 武田敦志 雨樋・瓦工事 千葉 千葉 1,120,000 200,000 雨樋
6 2018/9/12 杉田誠人 外壁塗装工事 千葉 千葉 1,010,000
7 2018/9/13 柴田洋子 屋根工事 野村 千葉 1,000,000 1%
8 2018/9/24 小川弘美 屋根工事 木村 千葉 954,000
を元に 条件 千葉さん ＾＾ 1.担当1か担当2、どちらかが千葉(双方、千葉も含む） 2.担当2＝千葉なら受付 3.担当1＝千葉なら打合せ 4.担当1と担当2、両方＝千葉なら受付と打合せ 5.その他判定（パーセント、若しくは文字列、金額、有り）。。。一応＾＾； 6.備考1に金額有り（請負金額、備考金額で2件書込み処理後、次の処理へ移行！） 6-1.題名、その他は取消、2.3.4.で判定した題名で金額はそのまま（請け負い金額） 備考（書込）は備考2（読込） 6-2.題名はその他に設定、金額は備考1の金額、備考は備考2 7.備考1に金額無し（5.のその他としての処理です） 7-1.題名はその他、金額はそのまま（請け負い金額）備考は備考1
それと、％表示は何某か1以下の少数が有り書式が％表示と推測して処理しています。 の様な条件で、下記コードを作成致しました。。。。禁断のgoto文、使っちまいましたが ＾＾； かなり冗長な感じです。。。アドバイス等ありましたらよろしくです。
Option Explicit
Private tanto, rr As Range
Private D, dkey As Long, i As Long
Private 題名, 契約日, 請負金額, お客様名, 他項目名E, 他項目名F, 備考, 担当1, 担当2
Private wb01 As Workbook
Sub main3()
m3ini
accept
book_add
For i = 2 To rr.Rows.Count
担当1 = rr(i, 4): 担当2 = rr(i, 5)
If 担当1 = tanto Or 担当2 = tanto Then
dai_set
If rr(i, 7) <> "" Or rr(i, 8) <> "" Then
If IsNumeric(rr(i, 7).Value) And rr(i, 7) > 1 Then
dev_wdata
GoTo stp1
End If
題名 = "その他"
請負金額 = rr(i, 6)
備考 = rr(i, 7)
End If
契約日 = rr(i, 1)
お客様名 = rr(i, 2)
dic_in
End If
stp1:
syokika
Next
dic_out
mysort
End Sub
Private Sub m3ini()
Set D = CreateObject("Scripting.Dictionary")
Set rr = Workbooks("9月まとめテスト.xlsm").Worksheets("Sheet1").Range("A1").CurrentRegion
End Sub
Private Sub accept()
Dim r As Range
tanto = Application.InputBox("担当者の姓名を入力してください。", "Excel-VBA", "千葉", , , , , 2)
If VarType(tanto) = vbBoolean Then Exit Sub
Set r = Union(rr.Columns(4), rr.Columns(5)).Find(what:=tanto, LookIn:=xlValues, lookat:=xlWhole)
If r Is Nothing Then
MsgBox "当該担当者の情報は有りません。" & vbLf & vbLf & tanto, vbCritical
Exit Sub
End If
End Sub
Private Sub book_add()
Set wb01 = Workbooks.Add
With ActiveSheet
.Cells(3, 2).Resize(1, 7) = Array("小題", "契約日", "お客様名", "請負金額", "他項目名", "他項目名", "備考")
End With
End Sub
Private Sub dai_set()
Select Case True
Case 担当1 = tanto And 担当2 <> tanto
題名 = "打合せ"
請負金額 = rr(i, 6)
Case 担当2 = tanto And 担当1 <> tanto
題名 = "受付"
請負金額 = rr(i, 6)
Case 担当1 = tanto And 担当2 = tanto
題名 = "受付と打合せ"
請負金額 = rr(i, 6)
End Select
End Sub
Private Sub dev_wdata()
備考 = rr(i, 8)
契約日 = rr(i, 1)
お客様名 = rr(i, 2)
dic_in
題名 = "その他"
請負金額 = rr(i, 7)
備考 = rr(i, 8)
dic_in
End Sub
Private Sub dic_in()
D(dkey) = Array(題名, 契約日, お客様名, 請負金額, 他項目名E, 他項目名F, 備考)
dkey = dkey + 1
End Sub
Private Sub syokika()
題名 = ""
契約日 = ""
お客様名 = ""
請負金額 = ""
他項目名E = ""
他項目名F = ""
備考 = ""
End Sub
Private Sub dic_out()
Dim buf, y As Long: y = 4
With wb01.Worksheets(1)
For Each buf In D.items
.Cells(y, 3).NumberFormatLocal = "yyyy/mm/dd"
.Cells(y, 5).NumberFormatLocal = "#,###"
.Cells(y, 2).Resize(1, 7) = buf
Select Case .Cells(y, 2)
Case "受付"
.Cells(y, 1) = 1
Case "受付と打合せ"
.Cells(y, 1) = 2
Case "打合せ"
.Cells(y, 1) = 3
Case "その他"
.Cells(y, 1) = 4
End Select
y = y + 1
Next
.UsedRange.Rows(5).EntireColumn.AutoFit
End With
End Sub
Private Sub mysort()
With wb01.Worksheets(ActiveSheet.Name).Sort
.SortFields.Clear
.SortFields.Add Key:=wb01.Worksheets(ActiveSheet.Name).Range("A3").CurrentRegion.Columns(1), _
SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
.SetRange wb01.Worksheets(ActiveSheet.Name).Range("A3").CurrentRegion
.Header = xlYes
.SortMethod = xlPinYin
.Apply
End With
wb01.Worksheets(ActiveSheet.Name).Range("A3").CurrentRegion.Columns(1).Clear
End Sub
で
実行結果が
A B C D E F G H
1
2
3 小題 契約日 お客様名 請負金額 他項目名 他項目名 備考
4 受付 2018/09/24 小川弘美 954,000
5 受付と打合せ 2018/09/04 武田敦志 1,120,000 雨樋
6 受付と打合せ 2018/09/12 杉田誠人 1,010,000
7 打合せ 2018/09/23 鈴木太郎 1,000,000
8 その他 2018/09/04 武田敦志 200,000 雨樋
9 その他 2018/09/13 柴田洋子 1,000,000 0.01
（砂糖）さん 2018/10/11(木) 12:27の結果と フォーマットは違いますが内容は同じかと ＾＾ 何分、推測の域をでておりません。外してましたら、ご容赦を m(__)m
（隠居じーさん） 2018/10/18(木) 09:59
[ 一覧(最新更新順) ]
YukiWiki 1.6.7 Copyright (C) 2000,2001 by Hiroshi Yuki.
Modified by kazu.