[ 初めての方へ | 一覧(最新更新順) | 全文検索 | 過去ログ ]
『エクセルVBA シート2こ別々の参照・計算・行挿入 について』（トマト）
VBAとても初心者のため いろいろな本を見ながら
ここは使えるかな？と継ぎ足し継ぎ足しいているため
全く変な命令文になっていると思います。がよろしくお願いいたします。
行いたKいことは
シート 目次 と シート 今回データ があり
シート今回データは
A B C D E・・・・K
郵便番号 住所 宛先 担当 雑誌・・・部数
A 500
B 500
C 500
と発送先が一覧となっています。
シート 目次 のB5 に数字を 入力したら
シート 今回データ のK の項目の数 を目次B5の数字で割って
その分 行数を 挿入して K部分を 割った数/部数（元の数）としたい
のです。
例 シート目次B5 に100 と入力したら
シート 今回データ の方を
A B C D E・・・・K
郵便番号 住所 宛先 担当 雑誌・・・部数
A 100/500
A 100/500
A 100/500
A 100/500
A 100/500
B 100/500
B 100/500
B 100/500
B 100/500
B 100/500
C 100/500
C 100/500
C 100/500
C 100/500
C 100/500
説明が下手ですみません。
Sub 項目変更()
Dim objworksheet As Worksheet
thiswork.book.Sheets ("今回データ") And ("目次") 'シート「今回データ」と「目次」を使用する
Set objworksheet = ActiveSheet
worksheets("今回データ").Select '「今回データ」の
Dim K As Long, length As Integer
For K = 2 To Cells(Rows.Count, 11).End(xlUp).Row
'[K]に関して2行目から最終行まで処理
worksheets("目次").Select '「目次」のB5の値を変数 Mとする
Dim M As Range
M = Range("B5")
Next K
Do Until K > M '「今回データ」の数が「目次」に入力した数字より大きかった時
'「今回データ」＞「目次入力数字」だった時
Selection.Rows.Select.Insert shift:=xlFormatFromLeftOrAbove And xlPasteValuesAndNumberFormats And ("/") And K
If ActiveCell.Value = K < M And K = M Then Exit Do
Selection.Rows.Select.Insert shift:=xlFormatFromLeftOrAbove And ("/") And K
Loop
End Sub
いろいろな本を見ながら付け足し付け足しで記入してみましたが
全くうごきませんでした。
上記を 見て 説明分のやりたい事柄がおわかりになる方が
いらっしゃいましたら
こうしたら改善するなど 教えてください。
よろしくお願いいたします。
＜ 使用 Excel：Excel2019、使用 OS：Windows10 ＞
まず、インデント（先頭部分の空白）をきれいにしててください。 こんな感じで。
いろいろ問題がありますが、それは後程。
Sub 項目変更()
Dim objworksheet As Worksheet
thiswork.book.Sheets ("今回データ") And ("目次") 'シート「今回データ」と「目次」を使用する
Set objworksheet = ActiveSheet
Worksheets("今回データ").Select '「今回データ」の
Dim K As Long, length As Integer
For K = 2 To Cells(Rows.Count, 11).End(xlUp).Row
'[K]に関して2行目から最終行まで処理
Worksheets("目次").Select '「目次」のB5の値を変数 Mとする
Dim M As Range
M = Range("B5")
Next K
Do Until K > M '「今回データ」の数が「目次」に入力した数字より大きかった時
'「今回データ」＞「目次入力数字」だった時
Selection.Rows.Select.Insert shift:=xlFormatFromLeftOrAbove And xlPasteValuesAndNumberFormats And ("/") And K
If ActiveCell.Value = K < M And K = M Then Exit Do
Selection.Rows.Select.Insert shift:=xlFormatFromLeftOrAbove And ("/") And K
Loop
End Sub
（QS） 2020/11/23(月) 20:54
取り合えず気になったところです。
Sub 項目変更()
Dim objworksheet As Worksheet
thiswork.book.Sheets ("今回データ") And ("目次") 'シート「今回データ」と「目次」を使用する
Set objworksheet = ActiveSheet
こういう記述はできませんので、
Dim mokujiWS As Worksheet
Set mokujiWS= ThisWorkbook.Worksheets("目次")
Dim dataWS As Worksheet
Set dataWS = ThisWorkbook.Worksheets("今回データ")
などに変更してください。
上を使うので、基本下のような Select は不要です。
Worksheets("今回データ").Select '「今回データ」の
Dim K As Long, length As Integer
For K = 2 To Cells(Rows.Count, 11).End(xlUp).Row
どのシートかを指定します。
For K = 2 To dataWS.Cells(Rows.Count, 11).End(xlUp).Row
でも、今回は For 文の必要なしかな。
M = mokujiWS.Rangte("B5").Value
前半はここまで。 （QS） 2020/11/23(月) 21:11
行が増減する処理は、後ろの方から処理します。 Dim lastRow lastRow = dataWS.Cells(Rows.Count,"K").End(xlUp).Row
Dim r
For r=lastRow To 2 Step -1
If dataWS.Cells(r,"K").Value > M Then
:
End If
Next
行の分割の部分はこんな感じでしょうか。
Dim lastRow
lastRow = dataWS.Cells(Rows.Count, "K").End(xlUp).Row
Dim r
Dim numRow
Dim orgNum
For r = lastRow To 2 Step -1
orgNum = dataWS.Cells(r, "K").Value '// 変更前の数値
If orgNum > M Then '// 分割の必要があれば
numRow = Application.WorksheetFunction.RoundUp(orgNum / M, 0) '// 分割後の行数
If numRow >= 2 Then '// ２行以上であれば
dataWS.Rows(r + 1 & ":" & r + numRow - 1).Insert '// 行を追加
dataWS.Rows(r).Copy dataWS.Rows(r + 1 & ":" & r + numRow - 1) '// 元の行をコピー
End If
dataWS.Cells(r, "K").Resize(numRow, 1) = M & "/" & orgNum '// K列を変更
If orgNum Mod M > 0 Then
dataWS.Cells(r, "K").Offset(numRow - 1, 0).Value = (orgNum Mod M) & "/" & orgNum '// 端数表示
End If
Else
dataWS.Cells(r, "K").Value = orgNum & "/" & orgNum '// M 以下の表示
End If
Next
（QS） 2020/11/23(月) 22:03
また、明日教えていただいたコードに記入しなおしながら
一文、一文 命令文の 解読から行ってみますので
お時間がもし、ありましたら また、教えて頂けると嬉しいです。
取り急ぎ、現状報告のみになり申し訳ありません。
よろしくお願いします。
（トマト） 2020/11/23(月) 22:19
返信ありがとうございます。 試せたときに、変更したい点等あったらコメントしてください。
一応全体をまとめたマクロを、変数を変えてみました。 ご参考までに。
Sub 項目変更()
Dim 目次WS As Worksheet
Set 目次WS = ThisWorkbook.Worksheets("目次")
Dim データWS As Worksheet
Set データWS = ThisWorkbook.Worksheets("今回データ")
Dim 区切量
区切量 = 目次WS.Range("B5").Value
Dim 最終行
最終行 = データWS.Cells(Rows.Count, "K").End(xlUp).Row
Dim 行
Dim 分割行数
Dim 変更前量
For 行 = 最終行 To 2 Step -1
変更前量 = データWS.Cells(行, "K").Value '// 変更前の数値
If 変更前量 > 区切量 Then '// 分割の必要があれば
分割行数 = Application.WorksheetFunction.RoundUp(変更前量 / 区切量, 0) '// 分割後の行数
If 分割行数 >= 2 Then '// ２行以上であれば
データWS.Rows(行 + 1 & ":" & 行 + 分割行数 - 1).Insert '// 行を追加
データWS.Rows(行).Copy データWS.Rows(行 + 1 & ":" & 行 + 分割行数 - 1) '// 元の行をコピー
End If
データWS.Cells(行, "K").Resize(分割行数, 1) = 区切量 & "/" & 変更前量 '// K列を変更
If 変更前量 Mod 区切量 > 0 Then
データWS.Cells(行, "K").Offset(分割行数 - 1, 0).Value = (変更前量 Mod 区切量) & "/" & 変更前量 '// 端数表示
End If
Else
データWS.Cells(行, "K").Value = 変更前量 & "/" & 変更前量 '// 区切量 以下の表示
End If
Next
End Sub
（QS） 2020/11/23(月) 22:45
今、マクロの1行1行を本を調べながら 命令文の解読を行っています。
分割行数 = Application.WorksheetFunction.RoundUp(変更前量 / 区切量, 0) '// 分割後の行数
↑上記命令文の区切りをどこでつけたらよいのか？わからず
本のどの項目を調べたらよいのか？がわかりません。
上記のコードを解読するには どの 項目で調べたらよいのか？
教えていただけないでしょうか？？
また、解読後になってしまうのですが（解読がなかなか進まず遅くてすみません）
Jの項目に 個別発送 メール便 と項目が分かれているのですが
メール便の数が 3から15 と小さいから？なのか？？？
最後の方の結果が 日付(3月3日など） になってしまうのです
通常通り数字で出るところは セルの 書式 が標準となっているのですが
最後の方のみ セルの 書式 が ユーザー定義 となってしまい日付になってしまいます。
どこをどのように変更したらよいでしょうか？
よろしくお願いします。
（トマト） 2020/11/24(火) 17:32
分割行数 = Application.WorksheetFunction.RoundUp(変更前量 / 区切量, 0) '// 分割後の行数 はEXCEL のシートの Roundup 関数をマクロで使用しているだけです。 変更前量 / 区切量 の結果を切り上げているだけなので、あまり複雑に考えない方が良いと思います。
マクロ内でシート関数を使用する際は（全部が使えるわけではありませんが、たいていは使える？） Application.WorksheetFunction を頭に付けます。
x/x としている部分が日付と解釈されてしまっているためですね。
処理の前にK列を文字列に指定してから実行したら大丈夫と思います。
マクロでやるには、
データWS.Colmns("K:K").NumberFormalLocal = "@" '// 文字列の指定
と指定します。
この辺りは、本やネットで調べてもよいですが、マクロの記録で取得できるので そこに出ているわからない言葉をネットで調べるようにするとよいかと思います。
各位置は
Set データWS = ThisWorkbook.Worksheets("今回データ")
の後ろあたりへ。
（QS） 2020/11/24(火) 17:39
マクロの記録 で 列 セルの書式設定 文字列 としたものを
コピーして 貼り付けてみたのですが
メール便の数が 少なく 日付になってしまう箇所は 日付のままでした。
どのように 下記 直したらよいでしょうか？
質問時のマクロの前に 別のマクロがあり 列がKからIへ変更となっています。
よろしくお願いします。
Sub 項目変更()
Dim 目次WS As Worksheet
Set 目次WS = ThisWorkbook.worksheets("目次")
'//変数「目次WS」はワークシート「目次」を参照
Dim データWS As Worksheet
'//変数「データWS」はワークシート「今回データ」を参照
Set データWS = ThisWorkbook.worksheets("今回ﾃﾞｰﾀ")
Columns("I:I").Select
Selection.NumberFormatLocal = "@"
' //文字列の指定 元部数/一箱に入れる部数 をしたとき 3/3 等になった時に3月3日とでてしまうため 書式設定しておく
（トマト） 2020/11/24(火) 20:17
なかなか最初はわかりずらいかもしれませんが、Select をしない書き方を覚えるとよいです。
Columns("I:I").Select
Selection.NumberFormatLocal = "@"
は
Columns("I:I").NumberFormatLocal = "@"
と書けます。
このあたりをご参考に。
http://officetanaka.net/excel/vba/speed/s2.htm
一度日付になってしまったデータは、再実行しても元には戻りませんので、実行前に保存するなどして 戻せるようにしてから試してください。 マクロで処理したものはアンドゥできませんので。
処理列が I になった場合、前回のコードはあちこちに K がありますが、すべてIに変更したでしょうか。 マクロはそこだけがおかしいという場合以外は、全体を提示したほうが解決が早いです。
特に不慣れな時は、思ったところとは違うところに原因があることも多いので。 （QS） 2020/11/24(火) 21:21
selectを使用しないように出来る様にとのご指摘ありがとうございます。
原本 として残しているデータを 今回データ シート へ貼り付けてsub＿項目変更（）
をためたのですが日付になってしまいます。
21：21のselectを使わない文面に直した 全体の文面を貼り付けます。
先ほど 部分のみのはりつけですみませんでした。
また、シート目次 のB5 に入力 していた 箇所も B18 と変更しています。
よろしくお願いします。
Sub 項目変更()
Dim 目次WS As Worksheet
Set 目次WS = ThisWorkbook.worksheets("目次")
'//変数「目次WS」はワークシート「目次」を参照
Dim データWS As Worksheet
'//変数「データWS」はワークシート「今回データ」を参照
Set データWS = ThisWorkbook.worksheets("今回ﾃﾞｰﾀ")
Columns("I:I").NumberFormatLocal = "@"
'// 文字列の指定 元部数/一箱に入れる部数 をしたとき 3/3 等になった時に3月3日とでてしまうため 書式設定しておく
Dim 区切量
'//変数「区切量」はワークシート「目次」のB：18を参照
区切量 = 目次WS.Range("B18").Value
Dim 最終行
最終行 = データWS.Cells(Rows.Count, "I").End(xlUp).Row
'//変数「最終行」はワークシート「今回データ」I列データの最終を参照
Dim 行
Dim 分割行数
Dim 変更前量
'//変数「変更前量」はワークシート「今回データ」のI列に元々入力されている数値（部数）を参照
For 行 = 最終行 To 2 Step -1
'//ワークシート「今回データ」のI列デーの最終行から上へ1つずつ
変更前量 = データWS.Cells(行, "I").Value '// 変更前の数値
If 変更前量 > 区切量 Then '// 分割の必要があれば
分割行数 = Application.WorksheetFunction.RoundUp(変更前量 / 区切量, 0) '// 分割後の行数
If 分割行数 >= 2 Then '// ２行以上であれば
データWS.Rows(行 + 1 & ":" & 行 + 分割行数 - 1).Insert '// 行を追加
データWS.Rows(行).Copy データWS.Rows(行 + 1 & ":" & 行 + 分割行数 - 1) '// 元の行をコピー
End If
データWS.Cells(行, "I").Resize(分割行数, 1) = 区切量 & "/" & 変更前量 '// I列を変更
If 変更前量 Mod 区切量 > 0 Then
データWS.Cells(行, "I").Offset(分割行数 - 1, 0).Value = (変更前量 Mod 区切量) & "/" & 変更前量 '// 端数表示
End If
Else
データWS.Cells(行, "I").Value = 変更前量 & "/" & 変更前量 '// 区切量 以下の表示
End If
Next
worksheets("目次").Select
Range("B18").Select
'//B:18列を選択する
Selection.Delete shift:=xlToLeft
'//B18列を削除する
End Sub
（トマト） 2020/11/24(火) 21:49
データWS.Cells(行, "I").Resize(分割行数, 1) = 区切量 & "/" & 変更前量
の書き方がまずかったようですね。
せっかく書式を設定しても、自動で処理されてしまっているようです。
データWS.Cells(行, "I").Resize(分割行数, 1).Value = 区切量 & "/" & 変更前量
のように、.Value を付けて、値を設定するように明示したら大丈夫のようです。
このあたりは、細かい話なのでどうしてかは、追々理解してけば良いと思います。 （QS） 2020/11/24(火) 23:31
横からすみません。
＞データWS.Cells(行, "I").Resize(分割行数, 1) = 区切量 & "/" & 変更前量 の書き方がまずかったようですね。 ＞データWS.Cells(行, "I").Resize(分割行数, 1).Value = 区切量 & "/" & 変更前量 のように、 ＞.Value を付けて、値を設定するように明示したら大丈夫のようです。
それはあり得ないと思います。
この種の事象について過去幾度となく議論していますが、 「等号の左側にあるRangeオブジェクト」に関しては、 .Valueのあるなしにかかわらず振る舞いは同じである、と言うのが結論です。
念の為、このトピを頭からトレースしてみましてが、同結論の通りでした。
反証となる事象の再現手順(データ、コード）があれば、ご提示をお願いします。
（半平太） 2020/11/25(水) 09:38
こちらでの試験時に、この一点の変更で動作が変わったために先のように記載しました。 データに関しては、日付になるように元データと、区切り量を12以下の数値でやった際に 現象が発生しました。
別の環境でもう一度確認してみます。
（QS） 2020/11/25(水) 11:48
今回データ を A1:K1 を AA、BB、CC、...、KK としてこれを １～6行目にコピー
その後 I2 12 I3 5 I4 7 I5 8 I6 4 として
目次 シートB18 に 4
として実行した際に、先の減少が発生しました。
直接の原因が挿入やコピーにあるかもしれませんが、Value の有無で現象が変わりました。 （QS） 2020/11/25(水) 12:01
人任せにしてしまい大変申し訳ありません。
どのようにしたらよいのか？が私には全くわからないので
お話を見ている感じになってしまいますが
よろしくお願いします。
（トマト） 2020/11/25(水) 12:12
トマトさんの環境では、コードを Value をつける対応をした際に、 結果に変化はなかったでしょうか？ （QS） 2020/11/25(水) 12:20
QSさん
申し訳ないですが、事象再現手順（データとコード）がさっぱり分かりません。 私が問題としているのはこの部分なんですけど。 ↓ ＞データWS.Cells(行, "I").Resize(分割行数, 1) = 区切量 & "/" & 変更前量 の書き方がまずかったようですね。 ＞データWS.Cells(行, "I").Resize(分割行数, 1).Value = 区切量 & "/" & 変更前量 のように、 ＞.Value を付けて、値を設定するように明示したら大丈夫のようです。
私が本トピをトレースしてテストした状況を説明します。 どこを変えると事象再現するのか、お分かりであればご指摘ください。
<ネタシート> 行 ____A____ __B__ __C__ __D__ _ E _ _ F _ __G__ __H__ _ I _ ___ J ___ ________K________ 1 郵便番号 住所 宛先 担当 雑誌 Item6 Item7 Item8 部数 データ型 1は数値型 2 A 10 1 J2セル =TYPE(I2) 3 B 15 1 J3セル =TYPE(I3) 4 C 21 1 J4セル =TYPE(I4)
<目次 サンプル> 行 _A_ __B__ _C_ 1 2 3 4 数字 5 5
以上の状態で「Value有無違いテスト」を実行する。
テストの流れは、 テスト開始時に「ネタ」シートをコピー、「今回データ」シートにペースト QSさんのプログラムを Valueありと、Valueなしで差異があるか検証する
Sub Value有無違いテスト()
Dim nonVal As Variant
For Each nonVal In Array(True, False)
項目変更 nonVal
Stop '結果を吸い上げ
Next
End Sub
Sub 項目変更(nonVal)
Dim 目次WS As Worksheet
Dim データWS As Worksheet
Dim 区切量
Dim 最終行
Dim 行
Dim 分割行数
Dim 変更前量
'テスト初期状態作成ーーーーーーーーーーーーーー
Sheets("ネタ").Cells.Copy
Sheets("今回データ").Select
Cells.Select
ActiveSheet.Paste
'テスト実行ーーーーーーーーーーーーーーーーーー
Set 目次WS = ThisWorkbook.Worksheets("目次")
Set データWS = ThisWorkbook.Worksheets("今回データ")
データWS.Columns("I:I").NumberFormatLocal = "@"
区切量 = 目次WS.Range("B5").Value
最終行 = データWS.Cells(Rows.Count, "I").End(xlUp).Row
For 行 = 最終行 To 2 Step -1
変更前量 = データWS.Cells(行, "I").Value '// 変更前の数値
If 変更前量 > 区切量 Then '// 分割の必要があれば
分割行数 = Application.WorksheetFunction.RoundUp(変更前量 / 区切量, 0) '// 分割後の行数
If 分割行数 >= 2 Then '// ２行以上であれば
データWS.Rows(行 + 1 & ":" & 行 + 分割行数 - 1).Insert '// 行を追加
データWS.Rows(行).Copy データWS.Rows(行 + 1 & ":" & 行 + 分割行数 - 1) '// 元の行をコピー
End If
'Value有無の違いテスト開始ーーーーーーーーーーーーーーーーーーーーーー
If nonVal = True Then
データWS.Cells(行, "I").Resize(分割行数, 1) = 区切量 & "/" & 変更前量 '// K列を変更
Else
データWS.Cells(行, "I").Resize(分割行数, 1).Value = 区切量 & "/" & 変更前量 '// K列を変更
End If
'Value有無の違いテスト終了ーーーーーーーーーーーーーーーーーーーーーー
If 変更前量 Mod 区切量 > 0 Then
データWS.Cells(行, "I").Offset(分割行数 - 1, 0).Value = (変更前量 Mod 区切量) & "/" & 変更前量 '// 端数表示
End If
Else
データWS.Cells(行, "I").Value = 変更前量 & "/" & 変更前量 '// 区切量 以下の表示
End If
Next
End Sub
実行結果は、.Valueの有無で違いは生じませんでした。
<今回データ 実行結果図> 行 ____A____ __B__ __C__ __D__ _ E _ _ F _ __G__ __H__ _ I _ ___ J ___ 1 郵便番号 住所 宛先 担当 雑誌 Item6 Item7 Item8 部数 データ型 2 A 5/10 2 3 A 5/10 2 4 B 5/15 2 5 B 5/15 2 6 B 5/15 2 7 C 5/21 2 8 C 5/21 2 9 C 5/21 2 10 C 5/21 2 11 C 1/21 2
（半平太） 2020/11/25(水) 14:47
上記の質問している ものは
昨日までは、毎回今回データシートをひらいてから マクロのデバックを使って動作を行い。結果をエクセルの（通常画面）へ確認へいっていました。
昨日の時点では、メール便の数の少ないものは（最終の方のみ）日付になっていましたが
現在 昨日との変更点2カ所あります。
?@今日はシート目次 に （すみません。名前を思い出せません。）灰色の四角いボタンを作り
そのボタンを押したら動くようにしたいと思いいじりました。
現状シートが
目次 前回データ 今回データ とあり
目次シート に四角い灰色のボタンを作り 押して動くようにいじりました。
?A昨日、selectはあまり使わない方がよいとお話を伺ったので
＞ worksheets("目次").Select
＞ Range("B18").Select
＞ '//B:18列を選択する
＞ Selection.Delete shift:=xlToLeft
＞'//B18列を削除する
＞ End Sub
の箇所を
＞ worksheets("目次").Activate
＞ Range("B18").ClearContents
＞
＞ 'B:18列を選択する
＞ 'B18に入力した数字を削除する
＞End Sub
へ直してみました。
本日は 昨日 日付になっていたところが 数字で出ています。
Sub 項目変更()
worksheets("今回ﾃﾞｰﾀ").Activate
Dim 目次WS As Worksheet
Set 目次WS = ThisWorkbook.worksheets("目次")
'//変数「目次WS」はワークシート「目次」を参照
Dim データWS As Worksheet
'//変数「データWS」はワークシート「今回データ」を参照
Set データWS = ThisWorkbook.worksheets("今回ﾃﾞｰﾀ")
Columns("I:I").NumberFormatLocal = "@"
'// 文字列の指定 元部数/一箱に入れる部数 をしたとき 3/3 等になった時に3月3日とでてしまうため 書式設定しておく
Dim 区切量
'//変数「区切量」はワークシート「目次」のB：18を参照
区切量 = 目次WS.Range("B18").Value
Dim 最終行
最終行 = データWS.Cells(Rows.Count, "I").End(xlUp).Row
'//変数「最終行」はワークシート「今回データ」I列データの最終を参照
Dim 行
Dim 分割行数
Dim 変更前量
'//変数「変更前量」はワークシート「今回データ」のI列に元々入力されている数値（部数）を参照
For 行 = 最終行 To 2 Step -1
'//ワークシート「今回データ」のI列デーの最終行から上へ1つずつ
変更前量 = データWS.Cells(行, "I").Value '// 変更前の数値
If 変更前量 > 区切量 Then '// 分割の必要があれば
分割行数 = Application.WorksheetFunction.RoundUp(変更前量 / 区切量, 0) '// 分割後の行数
If 分割行数 >= 2 Then '// ２行以上であれば
データWS.Rows(行 + 1 & ":" & 行 + 分割行数 - 1).Insert '// 行を追加
データWS.Rows(行).Copy データWS.Rows(行 + 1 & ":" & 行 + 分割行数 - 1) '// 元の行をコピー
End If
データWS.Cells(行, "I").Resize(分割行数, 1) = 区切量 & "/" & 変更前量 '// I列を変更
If 変更前量 Mod 区切量 > 0 Then
データWS.Cells(行, "I").Offset(分割行数 - 1, 0).Value = (変更前量 Mod 区切量) & "/" & 変更前量 '// 端数表示
End If
Else
データWS.Cells(行, "I").Value = 変更前量 & "/" & 変更前量 '// 区切量 以下の表示
End If
Next
worksheets("目次").Activate
Range("B18").ClearContents
'B:18列を選択する
'B18に入力した数字を削除する
End Sub （トマト） 2020/11/25(水) 15:05
＞本日は 昨日 日付になっていたところが 数字で出ています。
分数のような形ですね？ それで解決ですか？
ついでですが、こう言うのは出来るだけ、どのシートの列なのか明示するとバグが減ります。
↓
＞ Columns("I:I").NumberFormatLocal = "@"
↓
データWS.Columns("I:I").NumberFormatLocal = "@"
※今後の方針としてSelectを止めるという事は、Actviveシートが何であるか無関係に処理することになるので、 シートを明示しないと、その時点のActiveシートと解釈されるので、逆にトラブルに見舞われます。
（半平太） 2020/11/25(水) 15:49
当初の質問は出来た(解決した)のですが…
追加のようになり大変申し訳ないのですが
今回データシート
A. B. C D E... .K
郵便番号 住所 宛先 担当 雑誌 部数
A. 500 (元)となる箇所
B. 500(元)となる箇所
C. 300元)となる箇所
目次シート B18に数字を入力後 教えて頂いた 上記のマクロで
下記の形にする際に
Kに 分割した分の箱数を 出す事は 可能でしょうか？？
シート 今回データ の方を
A B C D E・・・・ K
郵便番号 住所 宛先 担当 雑誌・・・部数 分割箱数
A 100/500 ←(元). 1/5
A 100/500 2/5
A 100/500 3/5
A 100/500 4/5
A 100/500 5/5
B 100/500 ←(元)1/5
B 100/500 2/5
B 100/500 3/5
B 100/500 4/5
B 100/500 5/5
C 100/300 ←(元)1/3
C 100/300. 2/3
C 100/300. 3/3
よろしくお願いします
（トマト） 2020/11/25(水) 20:00
面倒なので数式での処理案
＞ Next
＞ Worksheets("目次").Activate
↓
Next
With データWS
With .Range("K2:K" & .Cells(.Rows.Count, "I").End(xlUp).Row)
.FormulaLocal = "=REPT(""←(元)"",C1<>C2)&COUNTIF(C$2:C2,C2)&""/""&COUNTIF(C:C,C2)"
.Copy
.PasteSpecial xlPasteValues, xlNone, False, False
End With
End With
Worksheets("目次").Activate
ところで、少し処理に時間が掛かっていないですか？
処理のスタート直後に Application.ScreenUpdating = False 処理の 終わり 直前に Application.ScreenUpdating = True
と入れて置くと少し改善すると思います。
（半平太） 2020/11/25(水) 22:30
本題に関係ないですが、現象が発生したと思われるシナリオだけ推測できたようなので一応報告です。
実行したのはトマトさんの下記コードですが、 （トマト） 2020/11/24(火) 21:49
ご指摘があった通り Value の部分ではなく、
> ＞ Columns("I:I").NumberFormatLocal = "@"
> ↓
> データWS.Columns("I:I").NumberFormatLocal = "@"
に起因していたと思われます。
元データの、数値部分の書式が「G/標準」でかつ「目次」シートを表示して実行 した場合に日付になったため、実行時の状態により差が出ていたようです。
今回の件に関しては
> データWS.Columns("I:I").NumberFormatLocal = "@"
にしておくことで、問題は回避できたかと思います。
今更ですが、ご報告まで。 （QS） 2020/11/26(木) 13:11
Dim 目次WS As Worksheet
Set 目次WS = ThisWorkbook.worksheets("目次") '//変数「目次WS」はワークシート「目次」を参照
Dim データWS As Worksheet
Set データWS = ThisWorkbook.worksheets("今回ﾃﾞｰﾀ") '//変数「データWS」はワークシート「今回データ」を参照
データWS.Columns("I:I").NumberFormatLocal = "@" '// 文字列の指定 元部数/一箱に入れる部数 をしたとき 3/3 等になった時に3月3日とでてしまうため 書式設定しておく
Dim 区切量 '//変数「区切量」はワークシート「目次」のB：18を参照
区切量 = 目次WS.Range("B18").Value
Dim 最終行
最終行 = データWS.Cells(Rows.Count, "I").End(xlUp).Row '//変数「最終行」はワークシート「今回データ」I列データの最終を参照
Dim 行
Dim 分割行数
Dim 変更前量 '//変数「変更前量」はワークシート「今回データ」のI列に元々入力されている数値（部数）を参照
For 行 = 最終行 To 2 Step -1 '//ワークシート「今回データ」のI列デーの最終行から上へ1つずつ
変更前量 = データWS.Cells(行, "I").Value '// 変更前の数値
If 変更前量 > 区切量 Then '// 分割の必要があれば
分割行数 = Application.WorksheetFunction.RoundUp(変更前量 / 区切量, 0) '// 分割後の行数
If 分割行数 >= 2 Then '// ２行以上であれば
データWS.Rows(行 + 1 & ":" & 行 + 分割行数 - 1).Insert '// 行を追加
データWS.Rows(行).Copy データWS.Rows(行 + 1 & ":" & 行 + 分割行数 - 1) '// 元の行をコピー
End If
データWS.Cells(行, "I").Resize(分割行数, 1) = 区切量 & "/" & 変更前量 '// I列を変更
If 変更前量 Mod 区切量 > 0 Then
データWS.Cells(行, "I").Offset(分割行数 - 1, 0).Value = (変更前量 Mod 区切量) & "/" & 変更前量 '// 端数表示
End If
Else
データWS.Cells(行, "I").Value = 変更前量 & "/" & 変更前量 '// 区切量 以下の表示
End If
Next
With データWS
With .Range("K2:K" & .Cells(.Rows.Count, "I").End(xlUp).Row)
.FormulaLocal = "=REPT(""←(元)"",C1<>C2)&COUNTIF(C$2:C2,C2)&""/""&COUNTIF(C:C,C2)"
.Copy
.PasteSpecial xlPasteValues, xlNone, False, False
End With
End With
worksheets("目次").Activate
Application.ScreenUpdating = True '処理速度を保つために処理の終わり直前に入れる物
Range("B18").ClearContents
'B:18列を選択する
'B18に入力した数字を削除する
End Sub
上記のように変更しました
結果 K列 に 分割した箱数が出たところ（宛先Bのところのみ分割箱数の表示あり） そのほかの
ところは0/0となってしまいました。
どこを どのように したらすべてに表示でるようになるでしょうか？
＿A_＿＿_B_＿＿＿_C_＿＿_D_＿_E＿_F＿_G＿_H＿_I_＿＿＿＿_J_＿K__________
1郵便番号 住所 宛先 発送部数
2 A 100/500 ←（元）0/0
3 A 100/500 0/0
4 A 100/500 0/0
5 A 100/500 0/0
6 A 100/500 0/0
7 B 100/500 ←(元）1/5
8 B 100/500 2/5
9 B 100/500 3/5
10 B 100/500 4/5
11 B 100/500 5/5
12 C 100/450 ←（元）0/0
13 C 100/450 0/0
14 C 100/450 0/0
15 C 100/450 0/0
16 C 50 /450 0/0
また、（元）と記入したのですが、質問の説明文ようだったので
申し訳ないです。
下記のように出すことは可能でしょうか？
よろしくお願いします。
＿A_＿＿_B_＿＿＿_C_＿＿_D_＿_E＿_F＿_G＿_H＿_I_＿＿＿＿_J_＿K__________
1郵便番号 住所 宛先 発送部数
2 A 100/500 1/5箱
3 A 100/500 2/5箱
4 A 100/500 3/5箱
5 A 100/500 4/5箱
6 A 100/500 5/5箱
7 B 100/500 1/5箱
8 B 100/500 2/5箱
9 B 100/500 3/5箱
10 B 100/500 4/5箱
11 B 100/500 5/5箱
12 C 100/450 1/5箱
13 C 100/450 2/5箱
14 C 100/450 3/5箱
15 C 100/450 4/5箱
16 C 50 /450 5/5箱
（トマト） 2020/11/26(木) 17:24
＞そのほかのところは0/0となってしまいました。 あり得ないと思うんですけどねぇ・・ 取り敢えず下の通り修正して、その結果を確認して貰ってから、本格的なトラブルシュートに入りたいです。
＞ With データWS
＞ With .Range("K2:K" & .Cells(.Rows.Count, "I").End(xlUp).Row)
＞ .FormulaLocal = "=REPT(""←(元)"",C1<>C2)&COUNTIF(C$2:C2,C2)&""/""&COUNTIF(C:C,C2)"
＞ .Copy
＞ .PasteSpecial xlPasteValues, xlNone, False, False
＞ End With
＞ End With
↓
With データWS
With .Range("K2:K" & .Cells(.Rows.Count, "I").End(xlUp).Row)
.FormulaLocal = "=COUNTIF(C$2:C2,C2)&""/""&COUNTIF(C:C,C2)&""箱"""
.Value = .Value
End With
End With
因みに、こちらではこうなっています。
行 ____A____ __B__ __C__ __D__ _ E _ _ F _ __G__ __H__ __ I __ J ____K____ 1 郵便番号 住所 宛先 担当 雑誌 Item6 Item7 Item8 部数 分割箱数 2 A 100/500 1/5箱 3 A 100/500 2/5箱 4 A 100/500 3/5箱 5 A 100/500 4/5箱 6 A 100/500 5/5箱 7 B 100/500 1/5箱 8 B 100/500 2/5箱 9 B 100/500 3/5箱 10 B 100/500 4/5箱 11 B 100/500 5/5箱 12 C 100/450 1/5箱 13 C 100/450 2/5箱 14 C 100/450 3/5箱 15 C 100/450 4/5箱 16 C 50/450 5/5箱
（半平太） 2020/11/26(木) 19:41
19：41 の 命令文へ変更後
__A____ __B__ __C__ __D__ _ E _ _ F _ __G__ __H__ __ I __ J ____K____
1 郵便番号 住所 宛先 担当 雑誌 Item6 Item7 Item8 部数 分割箱数 2 A 100/500 0/0箱 3 A 100/500 0/0箱 4 A 100/500 0/0箱 5 A 100/500 0/0箱 6 A 100/500 0/0箱 7 B 100/500 0/0箱 8 B 100/500 0/0箱 9 B 100/500 0/0箱 10 B 100/500 0/0箱 11 B 100/500 0/0箱 12 C 100/450 0/0箱 13 C 100/450 0/0箱 14 C 100/450 0/0箱 15 C 100/450 0/0箱 16 C 50/450 0/0箱
となりました。
エクセル
シートが 目次 前回データ 今回データ と並んでいます。
シート 目次 に
コマンドボタン ：１＿前処理（ボタン表記名）
文面で 指示 （毎回 メールで 今回データが送られてくるのでそれを手作業にて シート今回データにコピー 貼り付け）をしてから
コマンドボタン ：2＿都道府県項目変更（ボタン表記名）
B:18 に 一箱 に何部いれるか？数字を入力する
コマンドボタン ：3＿項目変更（ボタン表記名）
の手順で動かしています。
コマンドボタン ：1＿前処理 には
Sub 前準備()
Application.DisplayAlerts = False '「ｼｰﾄ削除確認」の警告ﾒｯｾｰｼﾞを表示しないようにする Falseの時（警告表示なし）
worksheets("前回ﾃﾞｰﾀ").Delete 'ｼｰﾄ 「前回ﾃﾞｰﾀ」 を削除する。
Application.DisplayAlerts = True 'DisplayAlertsﾌﾟﾛﾊﾟﾃｨで 警告ﾒｯｾｰｼﾞを表示するように戻す Trueの時（警告表示あり）
Dim objworksheet As Worksheet
ThisWorkbook.Sheets("今回ﾃﾞｰﾀ").Copy Before:=worksheets("今回ﾃﾞｰﾀ") 'ｼｰﾄ「今回ﾃﾞｰﾀ」をｼｰﾄ「今回ﾃﾞｰﾀ」の左側にｺﾋﾟｰする
Set objworksheet = ActiveSheet
objworksheet.Name = "前回ﾃﾞｰﾀ" '新しく挿入されたｼｰﾄ（ｺﾋﾟｰのあて先のｼｰﾄ）の名前を「前回ﾃﾞｰﾀ」とする
' worksheets("前回ﾃﾞｰﾀ").Cells.Interior.ColorIndex = xlNone '新しく挿入されたｼｰﾄ（ｺﾋﾟｰのあて先のｼｰﾄ）の ｼｰﾄについた色（黄色）を消す
worksheets("今回ﾃﾞｰﾀ").Cells.Clear 'ｼｰﾄ 「今回ﾃﾞｰﾀ」のﾃﾞｰﾀ を削除する。
worksheets("目次").Select
End Sub
worksheets("今回ﾃﾞｰﾀ").Activate
Application.ScreenUpdating = False
'全角を半角へ変換
'都道府県と住所直した後に列Aと列Cを削除する()
Dim R As Range
For Each R In Range("A2").CurrentRegion '"A2"セルを含む表全体を選択
R.Value = StrConv(R.Value, vbNarrow) '全角を半角へ変換する
Next R
'都道府県と住所直した後に列Aと列Cを削除する()
Dim i As Long, length As Integer
For i = 2 To Cells(Rows.Count, 1).End(xlUp).Row
'[A]に関して2行目から最終行まで処理
length = Len(Cells(i, 3).Value)
'列[C]の文字列の長さを調べる
If Left((Cells(i, 4).Value), length) <> Cells(i, 3).Value Then
'例。[東京都：新宿]の場合「Length」は[東京都]の文字列の長さ「３」が入っている
'「Left(Cells(i,4)Value,Length]で、「新宿区」の左から「３」文字を取り出し
'それが「東京都」と一致するかを調べている
'この場合「一致しないので
Cells(i, 4).Value = Cells(i, 3).Value & Cells(i, 4).Value
'列「D」に列「C」（「東京都」）と列「D」（「新宿区」）を足した文字列を書き込みます。
'「東京都：東京都渋谷区」の場合だと、列「C」の「東京都」と列「D」の左から「３」文字の「東京都」が一致するので
'なにもしません。
'「神奈川県：平塚市」のような場合
'列「D」から「４」文字、取り出せないがエラーにはならず不一致で
'「神奈川県平塚市」となる
End If
Next i
Columns("A:A").Select
'A列を選択する
Selection.Delete Shift:=xlToLeft
'A列を削除する
Columns("B:B").Select
'B列を選択する
Selection.Delete Shift:=xlToLeft
'B列を削除する
Application.ScreenUpdating = True
worksheets("目次").Activate
End Sub
Sub 項目変更()
worksheets("今回ﾃﾞｰﾀ").Activate
Application.ScreenUpdating = False '処理速度を保つために処理のスタート直後に入れる物
Dim 目次WS As Worksheet
Set 目次WS = ThisWorkbook.worksheets("目次")
'//変数「目次WS」はワークシート「目次」を参照
Dim データWS As Worksheet
'//変数「データWS」はワークシート「今回データ」を参照
Set データWS = ThisWorkbook.worksheets("今回ﾃﾞｰﾀ")
データWS.Columns("I:I").NumberFormatLocal = "@"
'// 文字列の指定 元部数/一箱に入れる部数 をしたとき 3/3 等になった時に3月3日とでてしまうため 書式設定しておく
Dim 区切量
'//変数「区切量」はワークシート「目次」のB：18を参照
区切量 = 目次WS.Range("B18").Value
Dim 最終行
最終行 = データWS.Cells(Rows.Count, "I").End(xlUp).Row
'//変数「最終行」はワークシート「今回データ」I列データの最終を参照
Dim 行
Dim 分割行数
Dim 変更前量
'//変数「変更前量」はワークシート「今回データ」のI列に元々入力されている数値（部数）を参照
For 行 = 最終行 To 2 Step -1
'//ワークシート「今回データ」のI列デーの最終行から上へ1つずつ
変更前量 = データWS.Cells(行, "I").Value '// 変更前の数値
If 変更前量 > 区切量 Then '// 分割の必要があれば
分割行数 = Application.WorksheetFunction.RoundUp(変更前量 / 区切量, 0) '// 分割後の行数
If 分割行数 >= 2 Then '// ２行以上であれば
データWS.Rows(行 + 1 & ":" & 行 + 分割行数 - 1).Insert '// 行を追加
データWS.Rows(行).Copy データWS.Rows(行 + 1 & ":" & 行 + 分割行数 - 1) '// 元の行をコピー
End If
データWS.Cells(行, "I").Resize(分割行数, 1) = 区切量 & "/" & 変更前量 '// I列を変更
If 変更前量 Mod 区切量 > 0 Then
データWS.Cells(行, "I").Offset(分割行数 - 1, 0).Value = (変更前量 Mod 区切量) & "/" & 変更前量 '// 端数表示
End If
Else
データWS.Cells(行, "I").Value = 変更前量 & "/" & 変更前量 '// 区切量 以下の表示
End If
Next
With データWS
With .Range("K2:K" & .Cells(.Rows.Count, "I").End(xlUp).Row)
.FormulaLocal = "=COUNTIF(C$2:C2,C2)&""/""&COUNTIF(C:C,C2)&""箱"""
.Value = .Value
End With
End With
worksheets("目次").Activate
Application.ScreenUpdating = True '処理速度を保つために処理の終わり直前に入れる物
Range("B18").ClearContents
'B:18列を選択する
'B18に入力した数字を削除する
End Sub
を登録しています。
メールで届く大本のデータは
A B C D E F G H I J K L
?ａ@郵便番号 都道府県 住所 住所2 宛先 役職 担当者 発送部数
1 埼玉県 埼玉県春日部市 500
2 東京都 練馬区 500
3 愛知県 名古屋市 400
となっていて 上記を 手作業で シート今回データ へ貼り付けて から
動作を行って
A B C D E F G H I J K
郵便場合 住所 住所2 宛先 役職 担当者 発送部数
埼玉県春日部市 500
東京都練馬区 500
愛知県名古屋市 400
にして行っています。
どこかが 影響しているなどで結果が半平太さんと違う理由は あるでしょうか？
よろしくお願いします。
（トマト） 2020/11/26(木) 21:07
当初の説明では、C列(宛先）に顧客名(A,B,C,D）が入っていたと思うんですが、 今回の説明では、C列は住所2だし、宛先はD列ですよね？
兎に角、下式のC(列）を、チャンと宛先データが入っている列に変更してください。
＞ .FormulaLocal = "=COUNTIF(C$2:C2,C2)&""/""&COUNTIF(C:C,C2)&""箱"""
例：D列なら .FormulaLocal = "=COUNTIF(D$2:D2,D2)&""/""&COUNTIF(D:D,D2)&""箱"""
（半平太） 2020/11/26(木) 22:47
D列(宛先）にはデータが入ってないんですか？
でしたら、データの在るB列にするしかないですが・・
.FormulaLocal = "=COUNTIF(B$2:B2,B2)&""/""&COUNTIF(B:B,B2)&""箱"""
（半平太） 2020/11/26(木) 22:54
半平太さん
質問する際に項目欄記述に 度重なる変更がありすみませんでした。
当初はこちらのマクロの作業のみ で質問をしていました
別のマクロを作動後にと 作業をふやしてしまったので
項目欄（ABCD)が変更となってしまいました。
上記、11/26 22：47 11/26 22：54 で
K に 箱数出すことが出来ました。
大変 お手数をおかけしまい申し訳ありませんでした。
とても助かりました。
ありがとうございました。
（トマト） 2020/11/27(金) 10:42
J に 発送手段 として 個別発送 メール便 と２種類の記載がるのですが
上記の 項目Jが メール便 だった場合の行のみ
いままで質問していた 計算（含む） マクロを適用範囲外 へすることは可能でしょうか？
行いたいことは
メール便のみ 発送数量（の桁）が違うため
目次シートに メール便用 の 分割のための 区切量 としているものを
G18 につくりたいと思っています。
度々のお願いとなり大変申し訳ありません。
（トマト） 2020/11/27(金) 13:53
難しい条件ではないように見えるのですが、処理をする部分に If で メール便だったら という条件を付けたらできないでしょうか。
うまく動かなくても、ご自身で手を入れたコードを提示して質問したら、多くの片が回答されるように 思います。 （QS） 2020/11/28(土) 09:25
If を新たに付け足そうとしてみましたが
QSさんに作ってもらったまとめマクロへ 新たにIF を付け足す場所、コードの記入方法が
わかっていなくて
動くには動いたようだったのですが。。。
動作後 発送部数は 空欄に 箱数も空欄になってしまいました。
どのように 変更したらよいでしょうか？？？
すみません。よろしくお願いします。
Sub 項目変更()
Worksheets("今回ﾃﾞｰﾀ").Activate
Application.ScreenUpdating = False '処理速度を保つために処理のスタート直後に入れる物
Dim 目次WS As Worksheet
Set 目次WS = ThisWorkbook.Worksheets("目次")
'//変数「目次WS」はワークシート「目次」を参照
Dim データWS As Worksheet
'//変数「データWS」はワークシート「今回データ」を参照
Set データWS = ThisWorkbook.Worksheets("今回ﾃﾞｰﾀ")
データWS.Columns("I:I").NumberFormatLocal = "@"
'// 文字列の指定 元部数/一箱に入れる部数 をしたとき 3/3 等になった時に3月3日とでてしまうため 書式設定しておく
Dim 区切量
'//変数「区切量」はワークシート「目次」のB：18を参照
区切量 = 目次WS.Range("B18").Value
Dim 最終行
最終行 = データWS.Cells(Rows.Count, "I").End(xlUp).Row
'//変数「最終行」はワークシート「今回データ」I列データの最終を参照
Dim 行
Dim 分割行数
Dim 変更前量
Dim 個メ判別
For 行 = 最終行 To 2 Step -1
'//ワークシート「今回データ」のI列デーの最終行から上へ1つずつ
変更前量 = データWS.Cells(行, "I").Value '//変数「変更前量」はワークシート「今回データ」のI列に元々入力されている数値（部数）を参照
個メ判別 = データWS.Cells(行, "J").Value '//変数「個メ判別」はワークシート「今回データ」のJ列に元々入力されている数値（個口・メール便）を参照
If 変更前量 > 区切量 & 個メ判別 = "個口発送" Then '// 分割の必要があれば
分割行数 = Application.WorksheetFunction.RoundUp(変更前量 / 区切量, 0) '// 分割後の行数
If 分割行数 >= 2 Then '// ２行以上であれば
データWS.Rows(行 + 1 & ":" & 行 + 分割行数 - 1).Insert '// 行を追加
データWS.Rows(行).Copy データWS.Rows(行 + 1 & ":" & 行 + 分割行数 - 1) '// 元の行をコピー
End If
データWS.Cells(行, "I").Resize(分割行数, 1) = 区切量 & "/" & 変更前量 '// I列を変更
If 変更前量 Mod 区切量 > 0 Then
データWS.Cells(行, "I").Offset(分割行数 - 1, 0).Value = (変更前量 Mod 区切量) & "/" & 変更前量 '// 端数表示
End If
Else
データWS.Cells(行, "I").Value = 変更前量 & "/" & 変更前量 '// 区切量 以下の表示
If 変更前量 > 区切量 & 個メ判別 = "ﾒｰﾙ便" Then
Else
データWS.Cells(行, "I").Value = 変更前数量
End If
End If
Next
With データWS
With .Range("K2:K" & .Cells(.Rows.Count, "I").End(xlUp).Row)
.FormulaLocal = "=COUNTIF(B$2:B2,B2)&""/""&COUNTIF(B:B,B2)&""箱"""
.Value = .Value
End With
End With
Range("K1") = "分割箱数"
データWS.Rows(1).Copy
Worksheets("今回メール便").Rows(1).PasteSpecial '項目名を今回メール便シートへコピー
Sheets("今回ﾃﾞｰﾀ").Select
Range("J1").Select
Selection.AutoFilter
ActiveSheet.Range("$A$1:$K$62").AutoFilter Field:=10, Criteria1:="ﾒｰﾙ便"
Cells.Select
Selection.Copy
Sheets("今回メール便").Select
Cells.Select
ActiveSheet.Paste
Range("A12").Select
Sheets("今回ﾃﾞｰﾀ").Select
Rows("55:77").Select
Application.CutCopyMode = False
Selection.ClearContents
Range("J58").Select
ActiveSheet.Range("$A$1:$K$62").AutoFilter Field:=10
Selection.AutoFilter
Sheets("目次").Select
Worksheets("目次").Activate
Application.ScreenUpdating = True '処理速度を保つために処理の終わり直前に入れる物
Range("B18").ClearContents 'B18に入力した数字を削除する
End Sub （トマト） 2020/11/28(土) 20:45
If 変更前量 > 区切量 & 個メ判別 = "ﾒｰﾙ便" Then
Else
データWS.Cells(行, "I").Value = 変更前数量
End If
End If
が変更した部分でしょうか？
If と End If の数があっていないようですが、
If 変更前量 > 区切量 & 個メ判別 = "ﾒｰﾙ便" Then
Else
データWS.Cells(行, "I").Value = 変更前数量
End If
でしょうか。
まず条件の書き方が
If 変更前量 > 区切量 & 個メ判別 = "ﾒｰﾙ便" Then
とはかけないので
If ( 変更前量 > 区切量 ) And ( 個メ判別 = "ﾒｰﾙ便" ) Then '// 括弧はなくとも良いですが、わかりやすくするために。
とします。
これ以外ということを書く場合 空にして Else にしてもよいのですが
If Not ( ( 変更前量 > 区切量 ) And ( 個メ判別 = "ﾒｰﾙ便" ) ) Then
データWS.Cells(行, "I").Value = 変更前数量
End If
あるいは
If ( 変更前量 <= 区切量 ) Or ( 個メ判別 <> "ﾒｰﾙ便" ) ) Then
データWS.Cells(行, "I").Value = 変更前数量
End If
のようにも書けます。
続きは後で。 （QS） 2020/11/28(土) 22:30
と思ったらインデント違いだったでしょうか。 取り合えず上のコメントは無視しておいてください。
変更前のコードはどの日時のものでしょうか？ （QS） 2020/11/28(土) 22:38
インデントとは構文の開始と終わりの位置を揃えることで、処理範囲や整合性を確かめるものです。 For 文だとこのような形になるので、参考にしてください。
For 行 = 最終行 To 2 Step -1 '//ワークシート「今回データ」のI列デーの最終行から上へ1つずつ
変更前量 = データWS.Cells(行, "I").Value '//変数「変更前量」はワークシート「今回データ」のI列に元々入力されている数値（部数）を参照
個メ判別 = データWS.Cells(行, "J").Value '//変数「個メ判別」はワークシート「今回データ」のJ列に元々入力されている数値（個口・メール便）を参照
If 変更前量 > 区切量 & 個メ判別 = "個口発送" Then '// 分割の必要があれば
分割行数 = Application.WorksheetFunction.RoundUp(変更前量 / 区切量, 0) '// 分割後の行数
If 分割行数 >= 2 Then '// ２行以上であれば
データWS.Rows(行 + 1 & ":" & 行 + 分割行数 - 1).Insert '// 行を追加
データWS.Rows(行).Copy データWS.Rows(行 + 1 & ":" & 行 + 分割行数 - 1) '// 元の行をコピー
End If
データWS.Cells(行, "I").Resize(分割行数, 1) = 区切量 & "/" & 変更前量 '// I列を変更
If 変更前量 Mod 区切量 > 0 Then
データWS.Cells(行, "I").Offset(分割行数 - 1, 0).Value = (変更前量 Mod 区切量) & "/" & 変更前量 '// 端数表示
End If
Else
データWS.Cells(行, "I").Value = 変更前量 & "/" & 変更前量 '// 区切量 以下の表示
If 変更前量 > 区切量 & 個メ判別 = "ﾒｰﾙ便" Then
Else
データWS.Cells(行, "I").Value = 変更前数量
End If
End If
Next
で、やりたいことを文章から推測すると、
For 行 = 最終行 To 2 Step -1 '//ワークシート「今回データ」のI列デーの最終行から上へ1つずつ
変更前量 = データWS.Cells(行, "I").Value '//変数「変更前量」はワークシート「今回データ」のI列に元々入力されている数値（部数）を参照
個メ判別 = データWS.Cells(行, "J").Value '//変数「個メ判別」はワークシート「今回データ」のJ列に元々入力されている数値（個口・メール便）を参照
If 個メ判別 = "個口発送" Then '// 分割の必要があれば
If 変更前量 > 区切量 Then
分割行数 = Application.WorksheetFunction.RoundUp(変更前量 / 区切量, 0) '// 分割後の行数
If 分割行数 >= 2 Then '// ２行以上であれば
データWS.Rows(行 + 1 & ":" & 行 + 分割行数 - 1).Insert '// 行を追加
データWS.Rows(行).Copy データWS.Rows(行 + 1 & ":" & 行 + 分割行数 - 1) '// 元の行をコピー
End If
データWS.Cells(行, "I").Resize(分割行数, 1) = 区切量 & "/" & 変更前量 '// I列を変更
If 変更前量 Mod 区切量 > 0 Then
データWS.Cells(行, "I").Offset(分割行数 - 1, 0).Value = (変更前量 Mod 区切量) & "/" & 変更前量 '// 端数表示
End If
Else
データWS.Cells(行, "I").Value = 変更前量 & "/" & 変更前量 '// 区切量 以下の表示
End If
Else
データWS.Cells(行, "I").Value = 変更前数量
End If
Next
ということでしょうか。
（QS） 2020/11/29(日) 00:11
If＿ の記入方法が
Iｆ＿条件式＿Then
処理1
Else
処理2
End If
上記の基本の形へ
処理1などのところへ、さらにIｆを処理へ入れる際に
どこへ、「If Else End If」を 入れるのがよくわからず
＞インデントとは構文の開始と終わりの位置を揃えることで、処理範囲や整合性を確かめるものです。
構文を そろえるスタート位置がよくわかっていません。すみません。
＞変更前のコードはどの日時のものでしょうか？
＞（QS） 2020/11/28(土) 22:38
コードは質問の20：45 を
11/26＿21：07のコードの指摘箇所11/26＿22：47＿22：54のコードに直し
さらに
Range("K1") = "分割箱数"
データWS.Rows(1).Copy
Worksheets("今回メール便").Rows(1).PasteSpecial '項目名を今回メール便シートへコピー
Sheets("今回ﾃﾞｰﾀ").Select
Range("J1").Select
Selection.AutoFilter
ActiveSheet.Range("$A$1:$K$62").AutoFilter Field:=10, Criteria1:="ﾒｰﾙ便"
Cells.Select
Selection.Copy
Sheets("今回メール便").Select
Cells.Select
ActiveSheet.Paste
Range("A12").Select
Sheets("今回ﾃﾞｰﾀ").Select
Rows("55:77").Select
Application.CutCopyMode = False
Selection.ClearContents
Range("J58").Select
ActiveSheet.Range("$A$1:$K$62").AutoFilter Field:=10
Selection.AutoFilter
Sheets("目次").Select
をマクロの記録で作り付け足したものになります。
QSさん・半平太さん に教えて頂いたマクロでできあがった
今回データ（シート）
に
マクロの記録で付けたしたのは今回データにフィルターをつけて
▼メール便 のみ データを出して 今回メール便シートへ切り取りコピーをして
シート今回データの１行目の項目をコピーして シート今回メール便シートへ貼り付けを
して フィルター機能を消して 最後に目次シートを開くようにしています。
付け足したいと思っている条件を日本語で書き出すと
もし、変更前量＞区切量の計算をするときにJ列が表記ﾒｰﾙ便だったら
今回データ（シート）のI列の表記は変更前の数を出す
としたいと思っています。
11/29 00：11の
For 行 = 最終行 To 2 Step -1 '//ワークシート「今回データ」のI列デーの最終行から上へ1つずつ
変更前量 = データWS.Cells(行, "I").Value '//変数「変更前量」はワークシート「今回データ」のI列に元々入力されている数値（部数）を参照
個メ判別 = データWS.Cells(行, "J").Value '//変数「個メ判別」はワークシート「今回データ」のJ列に元々入力されている数値（個口・メール便）を参照
If 個メ判別 = "個口発送" Then '// 分割の必要があれば
If 変更前量 > 区切量 Then
分割行数 = Application.WorksheetFunction.RoundUp(変更前量 / 区切量, 0) '// 分割後の行数
If 分割行数 >= 2 Then '// ２行以上であれば
データWS.Rows(行 + 1 & ":" & 行 + 分割行数 - 1).Insert '// 行を追加
データWS.Rows(行).Copy データWS.Rows(行 + 1 & ":" & 行 + 分割行数 - 1) '// 元の行をコピー
End If
データWS.Cells(行, "I").Resize(分割行数, 1) = 区切量 & "/" & 変更前量 '// I列を変更
If 変更前量 Mod 区切量 > 0 Then
データWS.Cells(行, "I").Offset(分割行数 - 1, 0).Value = (変更前量 Mod 区切量) & "/" & 変更前量 '// 端数表示
End If
Else
データWS.Cells(行, "I").Value = 変更前量 & "/" & 変更前量 '// 区切量 以下の表示
End If
Else
データWS.Cells(行, "I").Value = 変更前数量
End If
Next
へ変更してみたところ
今回メール便（シート）の発送部数 と 分割箱数 部分が 空欄と出ています。
質問文、説明文ともに 文面がわるくすみません。
よろしくお願いします。
（トマト） 2020/11/29(日) 13:51
今後も支障ありますのでインデントは一度理解いただけるでしょうか。 このあたりが分かりやすそうな気がしますが、インデント VBA で検索するといろいろあります。 https://thom.hateblo.jp/entry/2018/02/26/234247
断片的に記載内容を見て回答してしまっているので、もう一度質問内容を確認します。 トマトさんも、できるだけコードを理解して変更をご自身でできるよう頑張ってください。
やりたいことが増えるたびに質問は、いずれ破綻してしまいますので。 （QS） 2020/11/29(日) 14:24
（トマト） 2020/11/27(金) 10:42 で一度解決して、その後は追加の質問だったのですね。
このスレッドも長くなったので、次にそのようなことがあったら、前回の質問は [[20201123200729]] 『エクセルVBA シート2こ別々の参照・計算・行挿入』 で、・・・・と新しいスレッドにした方が良いと思います。
取り合えず、 >J に 発送手段 として 個別発送 メール便 と２種類の記載がるのですが >上記の 項目Jが メール便 だった場合の行のみ >いままで質問していた 計算（含む） マクロを適用範囲外 へすることは可能でしょうか？
はできていて、「今回メール便」シートが期待通りに表示されないということでしょうか。
（QS） 2020/11/29(日) 23:48
追加で質問です。 >今回メール便（シート）の発送部数 と 分割箱数 部分が 空欄と出ています。 発行部数、分割箱数、とはどのような情報（シート名、列など）でしょうか。
追伸： 途中からいろいろシートが増えているんですね。 状況に追いつけていません・・・。
もう少しスレッドの流れを追いかけてみます。 （QS） 2020/11/30(月) 00:08
次回より一度解決したのちに追加の質問の時は
下記の様に行います。すみません。
＞（トマト） 2020/11/27(金) 10:42
＞で一度解決して、その後は追加の質問だったのですね。
＞ このスレッドも長くなったので、次にそのようなことがあったら、前回の質問は
＞。[[20201123200729]] 『エクセルVBA シート2こ別々の参照・計算・行挿入』
＞ で、・・・・と新しいスレッドにした方が良いと思います。
質問が追加追加となりシートが増えてしまいすみません。
現在 出来たら と思うのがいろいろ文面追加していまい本当にすみません。
現在
シート目次B18に100と入力した時
下記を実行すると
Sub 項目変更()
Worksheets("今回ﾃﾞｰﾀ").Activate
Application.ScreenUpdating = False '処理速度を保つために処理のスタート直後に入れる物
Dim 目次WS As Worksheet
Set 目次WS = ThisWorkbook.Worksheets("目次")
'//変数「目次WS」はワークシート「目次」を参照
Dim データWS As Worksheet
'//変数「データWS」はワークシート「今回データ」を参照
Set データWS = ThisWorkbook.Worksheets("今回ﾃﾞｰﾀ")
データWS.Columns("I:I").NumberFormatLocal = "@"
'// 文字列の指定 元部数/一箱に入れる部数 をしたとき 3/3 等になった時に3月3日とでてしまうため 書式設定しておく
Dim 区切量
'//変数「区切量」はワークシート「目次」のB：18を参照
区切量 = 目次WS.Range("B18").Value
Dim 最終行
最終行 = データWS.Cells(Rows.Count, "I").End(xlUp).Row
'//変数「最終行」はワークシート「今回データ」I列データの最終を参照
Dim 行
Dim 分割行数
Dim 変更前量
'//変数「変更前量」はワークシート「今回データ」のI列に元々入力されている数値（部数）を参照
For 行 = 最終行 To 2 Step -1
'//ワークシート「今回データ」のI列デーの最終行から上へ1つずつ
変更前量 = データWS.Cells(行, "I").Value '// 変更前の数値
If 変更前量 > 区切量 Then '// 分割の必要があれば
分割行数 = Application.WorksheetFunction.RoundUp(変更前量 / 区切量, 0) '// 分割後の行数
If 分割行数 >= 2 Then '// ２行以上であれば
データWS.Rows(行 + 1 & ":" & 行 + 分割行数 - 1).Insert '// 行を追加
データWS.Rows(行).Copy データWS.Rows(行 + 1 & ":" & 行 + 分割行数 - 1) '// 元の行をコピー
End If
データWS.Cells(行, "I").Resize(分割行数, 1) = 区切量 & "/" & 変更前量 '// I列を変更
If 変更前量 Mod 区切量 > 0 Then
データWS.Cells(行, "I").Offset(分割行数 - 1, 0).Value = (変更前量 Mod 区切量) & "/" & 変更前量 '// 端数表示
End If
Else
データWS.Cells(行, "I").Value = 変更前量 & "/" & 変更前量 '// 区切量 以下の表示
End If
Next
With データWS
With .Range("K2:K" & .Cells(.Rows.Count, "I").End(xlUp).Row)
.FormulaLocal = "=COUNTIF(B$2:B2,B2)&""/""&COUNTIF(B:B,B2)&""箱"""
.Value = .Value
End With
End With
Range("K1") = "分割箱数"
Worksheets("目次").Activate
Application.ScreenUpdating = True '処理速度を保つために処理の終わり直前に入れる物
Range("B18").ClearContents
'B:18列を選択する
'B18に入力した数字を削除する
End Sub
今回データシート
A＿＿＿＿＿B＿＿C＿＿＿D＿＿＿E＿＿＿＿F＿＿＿G＿＿＿H＿＿I＿＿＿＿J＿＿＿＿K
郵便番号＿住所＿住所２＿宛先＿アイテム_担当者_ｱｲﾃﾑ＿TEL＿発送部数＿発送手段_分割箱数
A 100/500 個口発送 1/5箱
A 100/500 個口発送 2/5箱
A 100/500 個口発送 3/5箱
A 100/500 個口発送 4/5箱
A 100/500 個口発送 5/5箱
B 100/500 個口発送 1/5箱
B 100/500 個口発送 2/5箱
B 100/500 個口発送 3/5箱
B 100/500 個口発送 4/5箱
B 100/500 個口発送 5/5箱
C 15/15 ﾒｰﾙ便 1/1箱
D 10/10 ﾒｰﾙ便 1/1箱
E 10/10 ﾒｰﾙ便 1/1箱
F 5/5 ﾒｰﾙ便 1/1箱
G 3/3 ﾒｰﾙ便 1/1箱
となります。
目次シートG18 へ数字を入力したら（この数字がメール便の行数挿入の区切り量になるように
したい） 5 と入力していたら
元々のメール発送部数＜G18だったら 元々の発送部数を（分数の形ではなく）
元々のメール発送部数＞G18だったら 上記のマクロのように行を挿入して分数の形で表したい。
それを
A＿＿＿＿＿B＿＿C＿＿＿D＿＿＿E＿＿＿＿F＿＿＿G＿＿＿H＿＿I＿＿＿＿J＿＿＿＿K
郵便番号＿住所＿住所２＿宛先＿アイテム_担当者_ｱｲﾃﾑ＿TEL＿発送部数＿発送手段_分割箱数
A 100/500 個口発送 1/5箱
A 100/500 個口発送 2/5箱
A 100/500 個口発送 3/5箱
A 100/500 個口発送 4/5箱
A 100/500 個口発送 5/5箱
B 100/500 個口発送 1/5箱
B 100/500 個口発送 2/5箱
B 100/500 個口発送 3/5箱
B 100/500 個口発送 4/5箱
B 100/500 個口発送 5/5箱
C 5/15 ﾒｰﾙ便 1/3箱
C 5/15 ﾒｰﾙ便 1/3箱
C 5/15 ﾒｰﾙ便 1/3箱
D 5/10 ﾒｰﾙ便 1/2箱
E 5/10 ﾒｰﾙ便 1/2箱
F 5 ﾒｰﾙ便 1/1箱
G 3 ﾒｰﾙ便 1/1箱
が行いたい形になります。
今回メール便シートへ切り取り貼り付けなどは今回の質問内容から省いてください。
毎回、質問と説明文ともに長くわかりにくくしていってしまい
本当に本当にすみません。
（トマト） 2020/11/30(月) 12:29
VBA のコードもですが、表もどうも位置がずれているように思えるのですが、 見る環境によって異なるのでしょうか。
やりたいことは、
A＿＿＿＿＿B＿＿C＿＿＿D＿＿＿E＿＿＿＿F＿＿＿G＿＿＿H＿＿I＿＿＿＿J＿＿＿＿K
郵便番号＿住所＿住所２＿宛先＿アイテム_担当者_ｱｲﾃﾑ＿TEL＿発送部数＿発送手段_分割箱数
A 100/500 個口発送 1/5箱
A 100/500 個口発送 2/5箱
A 100/500 個口発送 3/5箱
A 100/500 個口発送 4/5箱
A 100/500 個口発送 5/5箱
B 100/500 個口発送 1/5箱
B 100/500 個口発送 2/5箱
B 100/500 個口発送 3/5箱
B 100/500 個口発送 4/5箱
B 100/500 個口発送 5/5箱
C 5/15 ﾒｰﾙ便 1/3箱
C 5/15 ﾒｰﾙ便 1/3箱
C 5/15 ﾒｰﾙ便 1/3箱
D 5/10 ﾒｰﾙ便 1/2箱
E 5/10 ﾒｰﾙ便 1/2箱
F 5 ﾒｰﾙ便 1/1箱
G 3 ﾒｰﾙ便 1/1箱
のようにしたいということでしょうか。
勝手に解釈すると、個別発送とメール便の分割単位をそれぞれ別に持ちたいということですか？ まったく違う内容を意図されていたらすみません。 （QS） 2020/11/30(月) 17:29
表も毎回ズレてしまいすみません。
入力時には、表を入力した際に揃って見える様に入力しているのですが
更新を押していざ、質問画面になるとズレてしまいます
すみません。
見えにくい、わかりにくい文から読みとって頂き
感謝しかありません。ありがとうございます。
11/30_QSさん17:29_の表のようにしたいです
個別発送とメール便の分割の際の区切量を2つに持ちたいです
目次シートB18に入力した数字(区切量) をJ(発送手段)が個口発送の時
目次シートG18に入力した数字(区切量)をJ(発送手段)がメール便の時
としたいです。
また、J(発送手段)がメール便の時にI(発送部数)<G18の時は
分数の形ではなく、整数(元のI(発送部数))で出るようにしたいです。
希望ばかりを押し付けてばかりで本当にすみません
（トマト） 2020/11/30(月) 18:37
とりあえず、変更内容を対応してみました。 コードもちょっと整理しました。
理解のためには、ステップ実行なんかも覚えてみてください。
Option Explicit
Sub 項目変更()
Worksheets("今回ﾃﾞｰﾀ").Activate
Dim 目次WS As Worksheet
Set 目次WS = ThisWorkbook.Worksheets("目次") '//変数「目次WS」はワークシート「目次」を参照
Dim データWS As Worksheet
Set データWS = ThisWorkbook.Worksheets("今回ﾃﾞｰﾀ") '//変数「データWS」はワークシート「今回データ」を参照
データWS.Columns("I:I").NumberFormatLocal = "@" '// 文字列の指定 元部数/一箱 が 3/3 などのとき 3月3日とでてしまう対応
'//-----------------------
'//------ 画面描画を無効にする
'//-----------------------
Application.ScreenUpdating = False '処理速度を保つために処理のスタート直後に入れる物
Dim 最終行
最終行 = データWS.Cells(Rows.Count, "I").End(xlUp).Row '//変数「最終行」はワークシート「今回データ」I列データの最終を参照
Dim 行
Dim 区切量
Dim 分割行数
Dim 変更前量 '//変数「変更前量」はワークシート「今回データ」のI列に元々入力されている数値（部数）を参照
For 行 = 最終行 To 2 Step -1 '//ワークシート「今回データ」のI列デーの最終行から上へ1つずつ
変更前量 = データWS.Cells(行, "I").Value '// 変更前の数値
'//-----------------------
'//------ 区切り量の設定
'//-----------------------
If データWS.Cells(行, "J").Value = "個口発送" Then '// 「メール」と「ﾒｰﾙ」 がどちらが正しいかわからないので「個別発送」で判定
区切量 = 目次WS.Range("B18").Value '// 個口発送の区切り量
Else
区切量 = 目次WS.Range("G18").Value '// メール便の区切り量
End If
'//-----------------------
'//------ 行の分割
'//-----------------------
If 変更前量 > 区切量 Then '// 【1】分割するときは
分割行数 = Application.WorksheetFunction.RoundUp(変更前量 / 区切量, 0) '// 分割後の行数
'//-----------------------
'//------ 行の追加 とコピー
'//-----------------------
If 分割行数 >= 2 Then '// ２行以上であれば
データWS.Rows(行 + 1 & ":" & 行 + 分割行数 - 1).Insert '// 行を追加
データWS.Rows(行).Copy データWS.Rows(行 + 1 & ":" & 行 + 分割行数 - 1) '// 元の行をコピー
End If
'//-----------------------
'//------ I列 xx/nn の記載
'//-----------------------
データWS.Cells(行, "I").Resize(分割行数, 1) = 区切量 & "/" & 変更前量 '// I列を変更
'//-----------------------
'//------ 割り切れないときの端数処理
'//-----------------------
If 変更前量 Mod 区切量 > 0 Then
データWS.Cells(行, "I").Offset(分割行数 - 1, 0).Value = (変更前量 Mod 区切量) & "/" & 変更前量 '// 端数表示
End If
Else '// 【２】分割しないときは
データWS.Cells(行, "I").Value = 変更前量 '// 区切量 以下のときはそのまま表示
End If
Next
'//-----------------------
'//------ J列の処理
'//-----------------------
With データWS.Range("K2:K" & データWS.Cells(データWS.Rows.Count, "I").End(xlUp).Row)
.FormulaLocal = "=COUNTIF(B$2:B2,B2)&""/""&COUNTIF(B:B,B2)&""箱"""
.Value = .Value
End With
'//-----------------------
'//------ 後処理
'//-----------------------
データWS.Range("K1") = "分割箱数"
目次WS.Activate
目次WS.Range("B18").ClearContents 'B18に入力した数字を削除する '// 消すのは B18 だけ？ G18は？
'//-----------------------
'//------ 画面描画を有効にする
'//-----------------------
Application.ScreenUpdating = True '処理速度を保つために処理の終わり直前に入れる物
End Sub
（QS） 2020/11/30(月) 19:25
行いたい結果になりました！！！
とても、とても、感謝しています。
19：25のコードにも、各処理をココで行っていると’///で記入して頂いたので
一つ一つ（QSさんの作ってくれたコードのみですが）なんとか処理が1行1行こうなっているのか～と
追えるようになりました。
1から10まで本当に本当にありがとうございました。
（トマト） 2020/11/30(月) 20:55
[ 一覧(最新更新順) ]
YukiWiki 1.6.7 Copyright (C) 2000,2001 by Hiroshi Yuki.
Modified by kazu.