Excel VBA質問箱 IV

当質問箱は、有志のボランティア精神のおかげで成り立っています。
問題が解決したら、必ずお礼をしましょうね。
本サイトの基本方針をまとめました。こちら をご一読ください。

投稿種別の選択が必要です。ご注意ください。
迷惑投稿防止のため、URLの入力を制限しています。ご了承ください。

  新規投稿 ┃ツリー表示 ┃一覧表示 ┃トピック表示 ┃検索 ┃設定 ┃過去ログ ┃ホーム  
133 / 13665 ﾂﾘｰ ←次へ　｜　前へ→
▼ 【81890】所定フォームへの流し込み ackkn 21/12/18(土) 8:20 質問[未読]
【81904】Re:所定フォームへの流し込み マナ 22/1/9(日) 19:30 発言[未読]
【81911】Re:所定フォームへの流し込み ackkn 22/1/20(木) 10:32 発言[未読]
【81912】Re:所定フォームへの流し込み ackkn 22/1/20(木) 11:31 発言[未読]
【81913】Re:所定フォームへの流し込み マナ 22/1/21(金) 19:30 発言[未読]
【81914】Re:所定フォームへの流し込み ackkn 22/1/21(金) 22:20 質問[未読]
【81915】Re:所定フォームへの流し込み マナ 22/1/22(土) 9:20 発言[未読]
【81916】Re:所定フォームへの流し込み ackkn 22/1/22(土) 12:42 回答[未読]
【81917】Re:所定フォームへの流し込み マナ 22/1/22(土) 14:05 発言[未読]
【81918】Re:所定フォームへの流し込み ackkn 22/1/22(土) 15:40 回答[未読]
【81919】Re:所定フォームへの流し込み マナ 22/1/22(土) 17:18 発言[未読]
【81920】Re:所定フォームへの流し込み ackkn 22/1/22(土) 19:21 回答[未読]
【81921】Re:所定フォームへの流し込み マナ 22/1/22(土) 20:18 発言[未読]
【81922】Re:所定フォームへの流し込み ackkn 22/1/22(土) 20:41 質問[未読]
【81923】Re:所定フォームへの流し込み マナ 22/1/22(土) 21:35 発言[未読]
【81924】Re:所定フォームへの流し込み ackkn 22/1/22(土) 21:48 回答[未読]
【81925】Re:所定フォームへの流し込み マナ 22/1/22(土) 23:22 発言[未読]
【81926】Re:所定フォームへの流し込み ackkn 22/1/22(土) 23:58 お礼[未読]
【81890】所定フォームへの流し込み
質問  ackkn  - 21/12/18(土) 8:20 -
引用なし
パスワード
   行き詰まり、時間が無く困っています。
無理なのかなとも思い始めましたが、どなたかご教示ください。
配送管理をやっています。　毎年年末になると、荷主様から主要配送先への送り込み予定データが送られてきます。それを、得意先、センター毎に品目、品名、数量をまとめます。ここまでは何とか自力で出来たのですが、最後にこの表から配送スケジュール表への落とし込みで行き詰まりました。
そのまとめた表が、下の表です。

日付　　　曜日　得意先　センター名　ケース数　パレット数　総数（kg）
2021/12/18(火)　　　　A社　　　　Aセンター　　　　1,153　　　　8　　　　　3,800
2021/12/16(木)　　　　A社　　　　Aセンター　　　　1　　　　1　　　　　100
2021/12/18(土)　　　　A社　　　　Aセンター　　　　1　　　　1　　　　　100
2021/12/23(木)　　　　A社　　　　Aセンター　　　　197　　　　2　　　　　700
2021/12/24(金)　　　　A社　　　　Aセンター　　　　2,442　　　　20　　　　　9,900
2021/12/18(土)　　　　A社　　　　Bセンター　　　　1,243　　　　9　　　　4,100
2021/12/24(金)　　　　A社　　　　Bセンター　　　　1,874　　　　14　　　　6,300
2021/12/24(金)　　　　A社　　　　Cセンター　　　　255　　　　5　　　　2,600
2021/12/24(金)　　　　A社　　　　Dセンター　　　　109　　　　3　　　　1,100

この表を元に、下の所定表（13日〜30日で固定）に変換したいのです。

得意先　センター名　13日 14日 15日 16日 17日 18日 19日20日21日22日 23日　24日 以降30日迄続く
　　　　　　　曜日　(月) (火) (水) (木) (金) (土) (日)(月)(火)(水) (木) (金)
―――――――――――――――――――――――――――――――――――――――
A社　　Aセンター　　　　1,153 8　　1 　1　　1　 1　　　　　　　　 197 2 2,442 20
　　　　　　　　　　　　3,800　　　100　　　100　　　　　　　　　　700　9,900　　　　
―――――――――――――――――――――――――――――――――――――――
A社　　Bセンター　　　　　　　　　　　　　 1,243 9　　　　　　　　　　　1,874 14
　　　　　　　　　　　　　　　　　　　　　　4,100　　　　　　　　　　　 6,300
―――――――――――――――――――――――――――――――――――――――
A社　　Cセンター　　　　　　　　　　　　　　　　　　　　　　　　　　　　255　 5
　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　2,600　　　　
―――――――――――――――――――――――――――――――――――――――
A社　Dセンター　　　　　　　　　　　　　　　　　　　　　　　　　　　　　109　3
　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　1,100
―――――――――――――――――――――――――――――――――――――――

各日の欄は｜　　　　　｜
―――――――――――
　　　　　｜1,153｜　8｜
―――――――――――
　　　　　｜　　 3,800｜
―――――――――――
このように3つの欄で、上段がケース数とパレット数で、下段が総数kgです。
この3つの欄がネックになっています。

よろしくご教示ください。
【81904】Re:所定フォームへの流し込み
発言  マナ  - 22/1/9(日) 19:30 -
引用なし
パスワード
   ▼ackkn さん：
>行き詰まり、時間が無く困っています。
>毎年年末になると、荷主様から主要配送先への送り込み予定データが送られてきます。


i今更ですが、2022年末用に。
Sheet2の日付と曜日は、手作業で用意しておいてください。

Option Explicit

Sub test()
　　Dim r1 As Range, r2 As Range
　　Dim v, n As Long, w()
　　Dim dic As Object
　　Dim s As String, k As Long
　　Dim d As Long
　　
　　Set r1 = Sheet1.Range("A1").CurrentRegion
　　Set r1 = Intersect(r1, r1.Offset(1))
　　
　　Set r2 = Sheet2.UsedRange.Offset(2)
　　r2.ClearContents

　　v = WorksheetFunction.Sort(r1, 3)
　　n = UBound(v)
　　ReDim w(n * 2, 1 To r2.Columns.Count + 1)
　　Set dic = CreateObject("scripting.dictionary")
　　
　　For k = 1 To n
　　　　s = v(k, 3) & vbTab & v(k, 4)
　　　　If Not dic.exists(s) Then
　　　　　　dic(s) = dic.Count * 2
　　　　　　w(dic(s), 1) = v(k, 3)
　　　　　　w(dic(s), 2) = v(k, 4)
　　　　End If
　　　　d = (Day(v(k, 1)) - 13) * 2 + 3
　　　　w(dic(s), d) = v(k, 5)
　　　　w(dic(s), d + 1) = v(k, 6)
　　　　w(dic(s) + 1, d + 1) = v(k, 7)
　　Next
　　
　　r2.Resize(dic.Count * 2, UBound(w, 2)).Value = w
　　
End Sub
【81911】Re:所定フォームへの流し込み
発言  ackkn  - 22/1/20(木) 10:32 -
引用なし
パスワード
   マナ様
お返事が遅くなって申し訳ありませんでした。
昨年は時間が無く、手作業で終えたものですから、本当に申し訳ありませんでした。
今から動作確認をしますので、改めて結果のご報告をいたします。
【81912】Re:所定フォームへの流し込み
発言  ackkn  - 22/1/20(木) 11:31 -
引用なし
パスワード
   マナ　様
早速ですが、確認しましたら、

　　v = WorksheetFunction.Sort(r1, 3)　の行で

下記エラーが出ました。

実行時エラー '1004':
WorksheetFunction クラスの Sort プロパティを取得できません。

よろしくお願いします。
【81913】Re:所定フォームへの流し込み
発言  マナ  - 22/1/21(金) 19:30 -
引用なし
パスワード
   ▼ackkn さん：
>
>実行時エラー '1004':
>WorksheetFunction クラスの Sort プロパティを取得できません。


エクセルのバージョンを教えて下さい。

>　 Set r1 = Sheet1.Range("A1").CurrentRegion
>　 Set r2 = Sheet2.UsedRange.Offset(2)

Sheet1の部分は、Sheets("実際のシート名")に変更してください。
Sheet2の部分も同様です。
【81914】Re:所定フォームへの流し込み
質問  ackkn  - 22/1/21(金) 22:20 -
引用なし
パスワード
   マナ さん

お世話になっております。

会社のPCで再現がありました。　Excel2019です。

ですが、元ネタの表がソート済でしたので、v = r1 として解決しました。

完動したら、完動しました！　素晴らしいです！！

で、あまりに高度なコードですので、ご相談なんですが、今回の所定表（13日〜
30日で固定）、実は少しフォームが違っていて、上段がケース数とパレット数で、
下段が総数kgを入れる部分がミソで、この部分が分かれば、後はアレンジすれば
いいと思っていたのですが、前述の通りあまりに高度なコードなので、アレンジ
が出来ません。

冒頭の v = r1 で、元ネタを配列 v に入れ、それで n = UBound(v) で行数を求め、ワーク配列 w() を Redim して、得意先　センター名を dictionary で重複
取る部分も、dic(s) = dic.Count * 2 の1行で、Add を使わなくても追加できる
んですね。　問題は、w() の使い方なんです。　最初、上段のケース数とパレッ
ト数だけが表示されて、下段の総数kgが全く表示されませんでした。
これは、下段のセルを結合していたためで、w(dic(s) + 1, d + 1) = v(k, 7)
を、w(dic(s) + 1, d) = v(k, 7)に変更して解決しました。

最後に、r2.Resize(dic.Count * 2, UBound(w, 2)).Value = w で、

所定表（13日〜30日で固定）に戻す部分なんです、この部分が、実際の表は、
今回の2行（上下段）の上下に付随行があり、1つの得意先＋センター名に対して
、4行単位なんです。　これに対応できません。
よろしくご教示ください。
【81915】Re:所定フォームへの流し込み
発言  マナ  - 22/1/22(土) 9:20 -
引用なし
パスワード
   ▼ackkn さん：

>今回の2行（上下段）の上下に付随行があり、1つの得意先＋センター名に対して
>、4行単位なんです。　これに対応できません。

i下記3行の、「 * 2 」を修正してください。

> ReDim w(n * 2, 1 To r2.Columns.Count + 1)
> dic(s) = dic.Count * 2
> r2.Resize(dic.Count * 2, UBound(w, 2)).Value = w


>
【81916】Re:所定フォームへの流し込み
回答  ackkn  - 22/1/22(土) 12:42 -
引用なし
パスワード
   マナ さん

ありがとうございます。

> ReDim w(n * 4, 1 To r2.Columns.Count + 1)
> dic(s) = dic.Count * 4
> r2.Resize(dic.Count * 4, UBound(w, 2)).Value = w

にして実行したところ、やはり左2列の得意先とセンター名は4行セットでいいので
すが、その右が得意先とセンター名の行に揃ってしまい、駄目です。
前回の2行を上下に他の2行に挟まれたサンドイッチの4行なので、1行ずれています。

この説明で伝わるでしょうか？
【81917】Re:所定フォームへの流し込み
発言  マナ  - 22/1/22(土) 14:05 -
引用なし
パスワード
   ▼ackkn さん：

>これは、下段のセルを結合していたためで、w(dic(s) + 1, d + 1) = v(k, 7)
>を、w(dic(s) + 1, d) = v(k, 7)に変更して解決しました。

これができたのだから、今回は、行と列が違うだけで、応用できませんか。
【81918】Re:所定フォームへの流し込み
回答  ackkn  - 22/1/22(土) 15:40 -
引用なし
パスワード
   ▼マナ さん：

dic(s) = dic.Count * 4 + 1 とすると、

得意先、センター名の見出し行に揃ってすべてが1行下にズレたので、左2列の得意
先、センター名だけは各4行の一番上にしたいので、その場合、

r2.Resize(dic.Count * 4, UBound(w, 2)).Value = w

の後に、左2列の得意先、センター名だけを1行上にズラした方が早いのでしょうか？
【81919】Re:所定フォームへの流し込み
発言  マナ  - 22/1/22(土) 17:18 -
引用なし
パスワード
   ▼ackkn さん：

例えば、ケース数なら、下記行を修正してください。

＞w(dic(s), d) = v(k, 5)

v(k, 5)は、ケース数
dic(s)は、行位置
dは、列位置
【81920】Re:所定フォームへの流し込み
回答  ackkn  - 22/1/22(土) 19:21 -
引用なし
パスワード
   ▼マナ さん

すいません、やっぱり伝えれませんでした。

dic(s) = dic.Count * 4 + 1 として実行すると、

得意先、センター名の見出し行に揃ってすべてが1行下にズレました。(下図)

得意先名　センター名　　　14日　　　　15日　　　　16日
　　　　　　　　曜日　　　(火)　　　　(水)　　　　(木)
-----------------------------------------------------------
　　　　　　　　　　｜　　　　　｜　　　　　｜　　　　　｜
-----------------------------------------------------------
　A社　　 Aセンター ｜1,153｜　8｜　　 ｜　 ｜　　1｜　1｜　　　　
-----------------------------------------------------------
　　　　　　　　　　｜ 　　3,800｜　　　　　｜　　　 100｜
-----------------------------------------------------------
　　　　　　　　　　｜　　　　　｜　　　　　｜　　　　　｜
===========================================================
　　　　　　　　　　｜　　　　　｜　　　　　｜　　　　　｜

これを、下図のようにしたいんです。

得意先名　センター名　　　14日　　　　15日　　　　16日
　　　　　　　　曜日　　　(火)　　　　(水)　　　　(木)
-----------------------------------------------------------
　A社　　 Aセンター ｜　　　　　｜　　　　　｜　　　　　｜
-----------------------------------------------------------
　　　　　　　　　　｜1,153｜　8｜　　 ｜　 ｜　　1｜　1｜　　　　
-----------------------------------------------------------
　　　　　　　　　　｜ 　　3,800｜　　　　　｜　　　 100｜
-----------------------------------------------------------
　　　　　　　　　　｜　　　　　｜　　　　　｜　　　　　｜
===========================================================
　　　　　　　　　　｜　　　　　｜　　　　　｜　　　　　｜
　　↑　　　 ↑

その為に、

r2.Resize(dic.Count * 4, UBound(w, 2)).Value = w の行で w() を表示した

後に、上の ↑ 2列を上に1行ズラした方が早いのでしょうか？
【81921】Re:所定フォームへの流し込み
発言  マナ  - 22/1/22(土) 20:18 -
引用なし
パスワード
   ▼ackkn さん：

>すいません、やっぱり伝えれませんでした。

何がしたか伝わっていますよ。

　　dic(s) = dic.Count * 4
　　w(dic(s), 1) = v(k, 3)　 ←得意先名
　　w(dic(s), 2) = v(k, 4)　 ←センター名
End If
d = (Day(v(k, 1)) - 13) * 2 + 3
w(dic(s), d) = v(k, 5)　 　　←ケース数
w(dic(s), d + 1) = v(k, 6)　 ←パレット数
w(dic(s) + 1, d) = v(k, 7)　 ←総数（kg）


変数wに値を代入するときに、
位置をずらせばよいです。
1次元目が行位置です。　　　　　　

w(行位置,列位置）
【81922】Re:所定フォームへの流し込み
質問  ackkn  - 22/1/22(土) 20:41 -
引用なし
パスワード
   ▼マナ さん

すいません、伝わっていないのは私でした。

w(dic(s) + 1, d) = v(k, 5)
w(dic(s) + 1, d + 1) = v(k, 6)
w(dic(s) + 2, d) = v(k, 7)

それぞれに +1 すれば良かったんですね。
ヒントが絶妙過ぎます。

バッチリでした。

それと、申し訳ないですが、力ずくでは出来るのですが、マナさんなら
スマートな方法で片付けられそうなので、スマートな方法お教えください。

上記の方法で、一番上にズラした得意先名とセンター名の2列で、同じ得意先と
同じセンター名のセルを結合したいのです。(下図)

得意先名　センター名　　　14日　　　　15日　　　　16日
　　　　　　　　曜日　　　(火)　　　　(水)　　　　(木)
-----------------------------------------------------------
　A社　　 Aセンター ｜　　　　　｜　　　　　｜　　　　　｜
-----------------------------------------------------------
　↓　　　　↓　　　｜1,153｜　8｜　　 ｜　 ｜　　1｜　1｜　　　　
-----------------------------------------------------------
　↓　　　　↓　　　｜ 　　3,800｜　　　　　｜　　　 100｜
-----------------------------------------------------------
　↓　　　　↓　　　｜　　　　　｜　　　　　｜　　　　　｜
===========================================================
　A社　　 Bセンター ｜　　　　　｜　　　　　｜　　　　　｜
-----------------------------------------------------------
　↓　　　　↓　　　｜　　　　　｜　　　　　｜　　　　　｜


　　↑＿＿＿＿↑＿ この2列
【81923】Re:所定フォームへの流し込み
発言  マナ  - 22/1/22(土) 21:35 -
引用なし
パスワード
   ▼ackkn さん：

>それと、申し訳ないですが、力ずくでは出来るのですが、

今度は何がしたいか、わかりません。
その力ずくのコードを提示してください。
【81924】Re:所定フォームへの流し込み
回答  ackkn  - 22/1/22(土) 21:48 -
引用なし
パスワード
   ▼マナ さん

得意先の列(B列)の場合です。C列も同様です。

'--- 得意先(B列)の結合
　　Rc = 6
　　Do While 1
　　　　If Rc = 6 Then
　　　　　　Tokui = Cells(Rc, 2).Value
　　　　　　Rm = Rc
　　　　　　Rc = Rc + 4
　　　　Else
　　　　　　If Cells(Rc, 2).Value = Tokui Then
　　　　　　　　Rc = Rc + 4
　　　　　　Else
　　　　　　　　If Cells(Rc, 2).Value = "" Then
　　　　　　　　　　With Range("B" & Rm & ":B" & Rc - 1)
　　　　　　　　　　　　.Merge
　　　　　　　　　　　　.HorizontalAlignment = xlCenter
　　　　　　　　　　End With
　　　　　　　　　　Exit Do
　　　　　　　　Else
　　　　　　　　　　Tokui = Cells(Rc, 2).Value
　　　　　　　　　　With Range("B" & Rm & ":B" & Rc - 1)
　　　　　　　　　　　　.Merge
　　　　　　　　　　　　.HorizontalAlignment = xlCenter
　　　　　　　　　　End With
　　　　　　　　　　Rm = Rc
　　　　　　　　　　Rc = Rc + 4
　　　　　　　　End If
　　　　　 End If
　　　　End If
　　Loop
【81925】Re:所定フォームへの流し込み
発言  マナ  - 22/1/22(土) 23:22 -
引用なし
パスワード
   ▼ackkn さん：

代わり映えしませんが

Sub test()
　　Dim r1 As Range
　　Dim r2 As Range
　　
　　Set r1 = Range("B6")
　　Set r2 = r1

　　Do
　　　　Set r2 = r2.Offset(4)
　　　　If r2.Value <> r1.Value Then
　　　　　　Range(r1, r2.Offset(-1)).Merge
　　　　　　r1.HorizontalAlignment = xlCenter
　　　　　　If r2.Value = "" Then Exit Do
　　　　　 Set r1 = r2
　　　　Else
　　　　　　r2.ClearContents
　　　　End If
　　Loop
　　
End Sub
【81926】Re:所定フォームへの流し込み
お礼  ackkn  - 22/1/22(土) 23:58 -
引用なし
パスワード
   ▼マナ さん：

>▼ackkn さん：
>代わり映えしませんが

何を仰います！

これです！、バッチリです！
よ〜〜く内容を理解して自分のものにしたいと思います。

理解できないところが出れば、質問させてください。
よろしくお願いします。

長々とありがとうございました。
  新規投稿 ┃ツリー表示 ┃一覧表示 ┃トピック表示 ┃検索 ┃設定 ┃過去ログ ┃ホーム  
133 / 13665 ﾂﾘｰ ←次へ　｜　前へ→
ページ：  ┃  記事番号：
2610219
(SS)C-BOARD v3.8 is Free