tatsu99様、何度もすみません

tatsu99様、前々回からお世話になっております。
http://climbi.com/b/10201/0
上記のマクロがようやく期待通りに動いたと思って抽出されたリストをよく見てみたら、
日付で指定した列の抽出データをコピーする際、空白部分を飛ばしてペーストされておりました。
空白部分も含めて列をコピーして貼り付けるようにしていただきたいのですが、可能でしょうか。

質問者からの補足コメント

• 回答ありがとうございます。
  ＞それとも、シート名が"R-1", "R-2", "R-3", "R-4", "A-1start", "Z-1start"の時から、このような状態が発生しているのでしょうか。
  すみません、説明不足でした。こちらでも発生している現象です。
  下記は抽出したリストの結果です。
  このデータの赤線部分をコピーして、別のシートに貼り付けつけます。

  
  No.2の回答に寄せられた補足コメントです。 補足日時：2017/05/25 08:39

• こちらの画像の左の列が実際の貼り付けられた結果で、
  私が理想としている(ASB-A152シートの)貼り付け結果が右の列です。
  実際に出ている結果ですと、空白部分が飛ばされて３のすぐ下に４が貼り付けられています。
  空白部分を飛ばさずにそっくりそのままコピペして欲しいのが理想の動きなのですが、可能でしょうか。
  お手数をおかけしますが、よろしくお願いいたします。

  
    補足日時：2017/05/25 08:43

• tatsu99様、回答ありがとうございます。
  指定の箇所をコメントアウトしてマクロを実行したのですが、
  列のデータは空白を飛ばして貼り付けられていました。
  右記URLは修正後のVBAです→ http://climbi.com/b/10222/0

  
  No.3の回答に寄せられた補足コメントです。 補足日時：2017/05/25 14:06

• 

  tatsu99様、ご提案ありがとうございます。
  
  ＞③と理解してますが、あってますか。
  
  はい、そうです、③です。
  
  ＞２）Ｎｏ３の補足の画像は、"ASB-A152"等のシートの画像ですか。
  
  はい、そうです。ASB-A152等のシート画像です。
  
  ＞３）４）が大変な場合は、直接そのExcelファイルを下記ＵＲＬに格納する方法もあります。
  
  お心遣いありがとうございます。
  今回は以前直していただいた「おみやげ表」のExcelファイルを使用しております。
  
  ＞Excelを格納したURLと保存時のパスワードを補足してください。
  
  右記URLとなります → http://xfs.jp/6vAn29
  パスワードは0525です。
  
  抽出データの貼り付け先となるセルと、
  おみやげ表に最後に値がペーストされるセルに色をつけておきました。
  お手数をおかけしますが、よろしくお願いいたします。

  No.4の回答に寄せられた補足コメントです。 補足日時：2017/05/25 15:50

• tatsu99様、回答ありがとうございます。
  早速試そうと思ったのですが、Error 502というものが表示されて、
  VBAを見ることができませんでした。(スマホ、PCどちらも)
  恐らくサーバー間での接続がうまくいっていないようなので、
  もうしばらくすれば見れるようになるのでしょうか。

  
  No.5の回答に寄せられた補足コメントです。 補足日時：2017/05/26 08:13

• tatsu99様、修正ありがとうございます。
  いただいたマクロの名前をシール用のブックに変えて入れてみたところ、
  最後に返ってくる値が、ASB-A152の分だけ値が返ってきませんでした(^_^;)
  本当に何度も申し訳ありません。
  抽出してコピーした後、ちゃんとASB-A152のシートにデータが
  貼り付けられているのですが、最後にシールというシートにペーストされるべき
  データが貼り付けされておらず、いただいたVBAを変更する際に
  私の方で記入ミスした可能性があると思うのですが、どこが間違っているのかわからない状態です。
  変更後のVBAを保存したテキストファイルを下記URLに保存しましたので、
  お手数ですが、確認してはいただけないでしょうか。
  
  http://xfs.jp/577Yi
  Pass 0526

  
  No.6の回答に寄せられた補足コメントです。 補足日時：2017/05/26 10:45

No.5 ベストアンサー 回答者： tatsu99 回答日時： 2017/05/25 18:18

いただいたExcelの方を修正しました。

下記ＵＲＬになります。
http://climbi.com/b/10201/1

おみやげ表の使用量が空白の時、各シート（札幌ラーメン等）の受注数には０を格納するようにしました。（これが最も少ない修正量なので）
おみやげ表の緑部分に集計結果を出力しますが、Case 33 等の数値（33）は、その品名に該当する行番号です。実際の設定にあわせてください。
（私の方でいただいたExcelのおみやげ表の緑部分にあわせました）

この回答へのお礼

申し訳ありません、自己解決できました！
私の方で行番号の変更に漏れがあっただけした、本当に申し訳ありません。
いただいたマクロを実行した結果、思い通りに動くようになり、
業務効率が大幅に上がりました。
tatsu99様、長らく親身なって教えていただき、本当にありがとうございました！

お礼日時：2017/05/26 11:05

No.6 回答者： tatsu99 回答日時： 2017/05/26 08:29

こちらからも、アクセスエラーになっていました。

もうしばらくすれば、回復すると思いますが、おなじものを投稿します。
-------------------------------------------------
Sub おみやげ()
Dim sh1 As Worksheet, sh2 As Worksheet
Dim hizuke As String, wnum As String
Dim rng As Range
Dim i As Long, imax As Long
Dim j As Variant, c As Long
Dim sname As String
Dim fsh As Variant
Dim siyou As Variant '追加①
fsh = Array("札幌ラーメン", "白いブラックサンダー", "弘前りんご", "夕張メロン", "白い恋人", "じゃがぽっくる")
hizuke = InputBox("日付を入力して下さい")
If hizuke = "" Then Exit Sub
If IsDate(hizuke) = False Then
MsgBox "日付不正"
Exit Sub
End If
Set sh1 = Worksheets("おみやげ表")
With sh1
Set rng = .Range(.Cells(4, 5), .Cells(4, .Cells(4, Columns.Count).End(xlToLeft).Column))
End With
j = Application.Match(CLng(CDate(hizuke)), rng, 0)
If IsError(j) Then
MsgBox "該当日付がありません"
Exit Sub
End If
wnum = InputBox("週を入力して下さい")
If wnum = "" Then Exit Sub
If wnum < 1 Or wnum > 5 Then
MsgBox "週不正"
Exit Sub
End If
Application.ScreenUpdating = False
c = wnum * 2 + 3
For Each sh2 In Worksheets
For i = 0 To 5
If sh2.Name = fsh(i) Then
With sh2
If .Cells(5, c) <> "" Then
.Range(.Cells(5, c), .Cells(.Cells(Rows.Count, c).End(xlUp).Row, c)).ClearContents
End If
End With
Exit For
End If
Next i
Next sh2
With sh1
imax = .Cells(Rows.Count, "A").End(xlUp).Row
For i = 6 To imax
If .Range("A" & i).Value <> "" Then
sname = .Range("D" & i).Value
Select Case sname
Case "弘前りんご", "夕張メロン", "白い恋人", "じゃがぽっくる"
Case Else
If (Left(sname, 6) = "札幌ラーメン") And InStr(sname, "人気商品") = 0 Then
sname = Left(sname, 6)
ElseIf (Left(sname, 10) = "白いブラックサンダー") And InStr(sname, "人気商品") = 0 Then
sname = Left(sname, 10)
Else
sname = ""
End If
End Select
If sname <> "" Then
Set sh2 = Worksheets(sname)
siyou = .Cells(i, j + 4) '追加②
If siyou = "" Then siyou = 0 '追加③
sh2.Cells(sh2.Cells(Rows.Count, c).End(xlUp).Row + 1, c).Value = siyou '変更④
End If
End If
Next i
For i = 33 To 41 '変更④ 32->33,40=>41(開始＝札幌ラーメンの行番号、終了＝じゃがぽっくるの行番号)
Set sh2 = Nothing
Select Case i
Case 33 '変更⑤-1 32->33（以降同様）札幌ラーメンの行
Set sh2 = Worksheets("札幌ラーメン")
Case 34 '変更⑤-2
Set sh2 = Worksheets("白いブラックサンダー")
Case 36 '変更⑤-3
Set sh2 = Worksheets("弘前りんご")
Case 38 '変更⑤-4
Set sh2 = Worksheets("夕張メロン")
Case 39 '変更⑤-5
Set sh2 = Worksheets("白い恋人")
Case 41 '変更⑤-6
Set sh2 = Worksheets("じゃがぽっくる")
End Select
If Not sh2 Is Nothing Then
.Cells(i, j + 4).Value = sh2.Cells(sh2.Cells(Rows.Count, c + 1).End(xlUp).Row, c + 1).Value
End If
Next i
End With
Application.ScreenUpdating = True
MsgBox "終了しました"
End Sub
-------------------------------------------------------
追加、変更の箇所は①から⑤です。

No.4 回答者： tatsu99 回答日時： 2017/05/25 14:51

>右記URLは修正後のVBAです→

http://climbi.com/b/10222/0
修正内容は間違っていません。ということは、私の回答が誤っていたことになります。
こうなると、正確に全体像をつかまないと、回答ができません。
以下の補足要求をお願いします。
１）今回期待した結果が出ないのは、どのシートでしょうか。
シールのシート・・・・・・①
"ASB-A152"等のシート・・・②
シール及び"ASB-A152"等のシート・・・③
③と理解してますが、あってますか。

２）Ｎｏ３の補足の画像は、"ASB-A152"等のシートの画像ですか。

３）シールのシートのセル位置がわかる情報（画像）を提示ください。

４）ASB-A152のシートのセル位置がわかる情報（画像）を提示ください。

もし、３）４）が大変な場合は、直接そのExcelファイルを下記ＵＲＬに格納する方法もあります。（無償で会員登録不要です）
http://firestorage.jp/
その場合は、Excelファイルに第3者にもれてはまずい情報があるなら、そこは、削除するか適当な情報に変えるかしてください。
（マクロの実行には影響しないことが前提です。）
必ず、第3者にみられても、構わない情報だけにしてください。
Excel格納後は、Excelを格納したURLと保存時のパスワードを補足してください。

No.3 回答者： tatsu99 回答日時： 2017/05/25 09:51

こちらで、確認していませんが、以下の修正を行ってみてください。

以下の①と②をコメントアウトしてください。
-------------------------------------------------------------
For i = 6 To imax
If .Range("A" & i).Value <> "" Then・・・・①
sname = .Range("D" & i).Value
Select Case sname
Case "YN40F01024D0", "KAB0737X-A(21)", "KRB1273X-A(11)", "KSB0852X-A(10)"
Case Else
If Left(sname, 8) = "ASB-A152" And InStr(sname, "中国") = 0 Then
sname = Left(sname, 8)
ElseIf Left(sname, 8) = "ASB-R162" And InStr(sname, "中国") = 0 Then
sname = Left(sname, 8)
Else
sname = ""
End If
End Select
If sname <> "" Then
Set sh2 = Worksheets(sname)
sh2.Cells(sh2.Cells(Rows.Count, c).End(xlUp).Row + 1, c).Value = .Cells(i, j + 4)
End If
End If・・・・②
Next i
----------------------------------------------------------------
行の先頭に'を付けるとコメント行になります。
'If .Range("A" & i).Value <> "" Then・・・・①
'End If・・・・②

コメント行になると文字が緑色になるのでそれも確認してください。

No.2 回答者： tatsu99 回答日時： 2017/05/24 22:21

ちなみに、このような状態が発生するのは、このマクロのみですか。

それとも、シート名が"R-1", "R-2", "R-3", "R-4", "A-1start", "Z-1start"の時から、このような状態が発生しているのでしょうか。
マクロのシート名に関する部分のみしか変更していないので、このような問題は、
シート名が"R-1", "R-2", "R-3", "R-4", "A-1start", "Z-1start"の場合も発生する可能性があると私は思っています。
もし、そうだとすると、何故、今回だけが問題になるのか、その理由が判らないので、確認した次第です。

No.1 回答者： tatsu99 回答日時： 2017/05/24 17:47

すみません。

状況がよくわかりません。
コピー元の図とコピー先の図を画像にして、提示していただけませんでしょうか。
コピー先の図は、「空白部分を飛ばしてペーストされている図」をお願いします。
又、コピー先の図に対して、このような結果を期待しているという説明もお願い致します。