[[20130403114539]]　『エクセルのオートフィルタをかけた可視セルを参照』（machi）　ページの最後に飛ぶ

[ 初めての方へ | 一覧(最新更新順) | 全文検索 | 過去ログ ]

　

『エクセルのオートフィルタをかけた可視セルを参照する方法について』（machi）

 エクセル２００７で、オートフィルタをかけたセルから必要なセルだけを、

他のシート（もしくは同じシート）で参照する方法について教えてください。

 フィルタオプションを使用して、範囲指定など行って他のセルに参照させる

方法を実施したのですが、この場合、もとのデータを変更しても参照先のデータが変更さ

れないため、目的にかなわないことがわかりました。

 通常のセルの参照のように、元のデータを変えれば参照セルの

データも変わるようなタイプでの可視セル参照方法はどのようにすればできるのでしょう

か。　部署でフィルタをかけて「あ」をのみを選択。「あ」部署の、

ある物品の毎月の使用量を月別に表示し、その可視セルを他のシートに参照させたいとい

う感じです。　　　すべての部署別に一覧にしたいため、いちいちコピーして

可視セル貼付けですと、かなり手間がかかってしまうため、方法を検討しているところです。

        Ａ  　　Ｂ  　　Ｃ　  　Ｄ　
 −−−−−−−−−−−−−−−−−−−−−−−−−−−−−−−
 １　　月日　　部署　　物品　　使用量
 −−−−−−−−−−−−−−−−−−−−−−−−−−−−−−−
 ２　　4月　　　あ　　　○　　　2000
 −−−−−−−−−−−−−−−−−−−−−−−−−−−−−−−
 ３　　5月　　　い　　　○　　　2500
 −−−−−−−−−−−−−−−−−−−−−−−−−−−−−−−
 ４　　5月　　　あ　　　○　　　6800
 −−−−−−−−−−−−−−−−−−−−−−−−−−−−−−−
 ５　　7月　　　え　　　○　　　500
 −−−−−−−−−−−−−−−−−−−−−−−−−−−−−−−
 ６　　6月　　　あ　　　○　　　4800
 −−−−−−−−−−−−−−−−−−−−−−−−−−−−−−−

 よろしくお願いいたします。ＯＳはＸＰです。（エクセル２０１３でWindows８もありますので、どちらかでお願いいたします。）

---

 参照させたいというのが具体的にどうしたいのかが判らないので目的に合うかは判らず。

 例えばE列を作業列として
 E2セルに
 =IF(D2<>"",SUBTOTAL(9,D2),0)
 と入力してE6セルまでコピー。

 これでE列は非表示の行は0、表示されている行はD列と同じ値が表示される。

 あとはSUMIFSなどを使って抜き出せないか？
 (ねむねむ)

---

 オートフィルタ使わないで、最初っからフィルタオプション使うんじゃダメかな？

http://www.eurus.dti.ne.jp/~yoneyama/Excel2007/excel2007-filter2.html
Excel2007(エクセル2007)基本講座：データの抽出(フィルタ　オプションの設定)

 (1111)

---

ねむねむさま
ありがとうございます。教えていただいた方法を試してみました。
これを、別のシートに表示させる方法について教えていただいても良いでしょうか。
１０種類の物品、５０部署の１年分のデータが、各物品別に別々のシートに集計されており、
これを、今度は部署別に各物品使用量一覧にする必要がある状態です。(下記のような感じに）

        Ａ  　　Ｂ  　　Ｃ　  　Ｄ　
 −−−−−−−−−−−−−−−−−−−−−−−−−−−−−−−
 １　　月日　　部署　　物品　　使用量
 −−−−−−−−−−−−−−−−−−−−−−−−−−−−−−−
 ２　　4月　　　あ　　　○　　　2000
 −−−−−−−−−−−−−−−−−−−−−−−−−−−−−−−
 ３　　4月　　　あ　　　▽　　　2500
 −−−−−−−−−−−−−−−−−−−−−−−−−−−−−−−
 ４　　4月　　　あ　　　◆　　　6800
 −−−−−−−−−−−−−−−−−−−−−−−−−−−−−−−
 ５　　4月　　　あ　　　★　　　500
 −−−−−−−−−−−−−−−−−−−−−−−−−−−−−−−
 ６　　4月　　　あ　　　○　　　4800
 −−−−−−−−−−−−−−−−−−−−−−−−−−−−−−−
 各物品別にあるシート上で、部署「あ」をオートフィルタで選んだ時は、別シートに部署「あ」の物品使用量一覧が表示され、
 部署「い」を選んだ時は、同じ別シートに部署「い」の物品使用量一覧が表示される、といった感じになるとうれしいのです。
エクセルは初心者で、どの言葉を使用するとうまく伝わるのかわからず、お手数をおかけしますが、よろしくお願いいたします。(machi)

---

 物品ごとにシートが分かれているデータがある。
 その中から、指定した部署のデータだけを集めて
 一覧にしたい。
 って事ですよね？

 現在の最大の問題点は
 ＞物品ごとにシートが分かれている
 って事だと思います。

 シートが分かれているから
 ＞部署でフィルタをかけて「あ」をのみを選択。
 の作業も、シート数だけしないといけないですよね。

 データ量等、色々な条件もあるとは思いますが

 入力は一つのシートにずらずらっと　行う。
 　　今回はこれ以上増えないなら、とにかく一つのシートにデータを集める。
 もう一つシートを作って
 　特定の物品のデータが見たい場合は、その物品だけを抜き出して表示。
 　特定の部署のデータが見たい場合は、その部署だけを抜き出して表示。
 と言った構成にすると、作業も少しは簡単になると思います。

 　　データが一つの表にまとまっていれば
 　　フィルタで絞り込むだけで、目的の表になりそうですが・・・

 構成の変更が出来ない場合、同じ作業を繰り返すのは面倒なので
 マクロを使って、エクセルにやらせるのが得策に思えます。

 マクロ(VBA)が使える環境であれば、もっと具体的に状況の説明をしてもらうと良いと思います。
 たとえば、
 　・各物品別のデータが入っているシートと、その他のシートとの見分け方
 　・物品使用量一覧を表示したいシート名
 等。

 (HANA)

---

HANAさま

 アドバイスありがとうございます。
 そして、私の拙い説明を理解していただき、本当にありがとうございます！

 構成の変更に関しては、外部業者が出してくるデータなので無理だと言われました。
 提出されるデータは、１か月ごとに１つのシートに１商品の出庫量等が全部署分入っています。
 また、各商品によって表示されている項目（出庫量やメーカー名、出庫日時など）がバラバラなため、１つのシートにまとめるにも、項目を合わせるだけでかなり難渋する状態です）
 ちなみにデータは日々増殖中です。

 マクロは使用しても良いそうです。
 ですが、私は「マクロの記録」というもので数回使用したことがある程度で、あの難しい言語？は自力ではまったく組めない状態です。

 ＞マクロ(VBA)が使える環境であれば、もっと具体的に状況の説明をしてもらうと良いと思います。
 たとえば、
 ・各物品別のデータが入っているシートと、その他のシートとの見分け方
 →こちらは、シートに各商品名が入っている状態です。
 ・物品使用量一覧を表示したいシート名
 →こちらは、○○部署という形で全部署分作成する予定です。
(machi)

---

 ＞１か月ごとに１つのシートに１商品の出庫量等が全部署分入っています。
 完成させるデータも、１か月ごとで良いのでしょうか？

 元データは
 ＞１０種類の物品、５０部署の１年分のデータが
 って話だったと思いますが。。。

 ＞各商品によって表示されている項目（出庫量やメーカー名、出庫日時など）がバラバラなため、〜〜
 そのうち、必要な項目は決まっているのですよね？
 項目名等は統一されていてピックアップすれば良いのでしょうか？

 項目数は、いくつくらいあるのでしょう？

 ＞マクロは使用しても良いそうです。〜〜
 それは良かったです。
 誰でも初めての時はあります。
 VBAは多くの一般の人が使っているものですから、意気込み次第だと思っています。

 コードを作りにあたり、machiさんに説明してもらわないといけないことがあります。
 目の前にエクセルファイルが無い状態で、その仕事の引き継ぎをする場合を想定して下さい。
 どの様に説明しますか？

 全てのデータシートでフォーマットが同じで、結果も同じフォーマットで良いのなら話は簡単ですが
 　　（当初のご説明に＋で「どのシートが、各物品別のデータが入っているシートなのか　等」
 　　　の説明があれば滞りなく作業が出来ると思います。）
 実際はそうでは無い様ですので。。。

 特徴的ないくつかのシートを例に挙げて説明してもらえますか？
 　・必要な項目（物品使用量一覧に表示が必要な項目）
 　・各物品別の　シート名、項目とその並び
 等

 (HANA)

---

HANAさま
・ 完成させるデータも、１か月ごとで良いのでしょうか？
→はい。１か月ごとに必要になります。１年分が同じシートで良いのですが、４月から順番に表になっている必要があります。

・必要な項目（物品使用量一覧に表示が必要な項目）
\x{fffd}@商品名、\x{fffd}A出庫月、\x{fffd}B部署名、\x{fffd}C出庫量、\x{fffd}D実働使用量（これは、１本が５００ｍｌの洗剤が３個出庫だった場合、１５００ｍｌとなります）です。
外部業者が提出するデータは、項目名が統一されていないため、該当するものを選んでいく必要があります。
また、提出されるデータの項目数は業者によって4-10個と幅があります。

・各物品別のシート名、項目とその並び

 最も煩雑なデータを提出する業者のものを例にあげます。
 物品別シート名：「サニサーラ２５０ｍｌ」
 項目名：薬品コード、薬品名称、規格、包装数、出庫先、出庫数、出庫返品数、実出庫数、実出庫金額です。各列に１項目ではなく、行を変えて違う項目を入力してあります。↓
       　　Ａ  　　　　Ｂ  　　　　Ｃ  　　　　Ｄ　　　　E　
 −−−−−−−−−−−−−−−−−−−−−−−−−−−−−−−
 １　　薬品コード　　薬品名称　　　　　　　　規格　　　包装数　
 −−−−−−−−−−−−−−−−−−−−−−−−−−−−−−−
 ２　　サニサ40　　　サニサーラ　　　　　　　250ｍｌ　　１  
 −−−−−−−−−−−−−−−−−−−−−−−−−−−−−−−
 ３　　部署　　　　出庫数　　　出庫返品数　　出庫実働数…　　
 −−−−−−−−−−−−−−−−−−−−−−−−−−−−−−−
 ４　　あ　　　　　　46　　　　　　1　　　　　45
 −−−−−−−−−−−−−−−−−−−−−−−−−−−−−−−
 また、１月で出庫が0だった部署は入力されないため、部署名も毎月並びが変わってしまいます。
部署名は何かを参照しているのか、=RIGHT(A6,LEN(A6)-FIND("／",A6))という数式？が入っており、普通にコピーすると他のセルには部署名がコピーされませんでした。

 ＞１０種類の物品、５０部署の１年分のデータ〜
 各物品別に１月ごとに集計されているデータを、１年分にまとめたのは私です。
 各物品別ならば、項目名数に変化がないためコピーしやすかったものですから。
 １０回フィルターをかけなおすのは面倒ですが、もうとにかくこれでフィルターをかけて、別のシートで参照させるくらいしか、手を思いつきませんで…。
 データ量は、１つの物品で1000桁まで行数がいく状態でした。
 なので、10個ですと10000桁になるんでしょうか。
 今あるデータだけでしたら、HANAさまに教えていただいたとおり、不要な項目を削除して、すべて同じシートに入れてしまうのが一番手っ取り早いかもしれません。
 ただ、毎月増殖していくのでそれらをどうすれば良いのか不安です。

・どの様に説明しますか？
これは難しいです〜。

 ４つの業者から、１年間に納入された物品のデータが提出されています。
 提出されたデータ内容は、業者ごとに報告項目が違っていますが、これから作成するデータに必要なデータは揃っています。
 また、元データは、納入している物品別にシートを分けて、１月分ずつ全部署分のデータが入った状態で作成されています。
 このデータを、各部署別に分け、毎月の物品の実働使用量を出して提出しなければなりません。
 こんな感じでしょうか。我ながらわかりにくいです。申し訳ありません。よろしくお願いいたします。

---

 ＞各列に１項目ではなく、行を変えて違う項目を入力してあります。↓
 それは厄介ですね。

 全てそうなんでしょうか？
 それとも、物品によって　その様になっているシートもあるし
 １行で完結しているシートもある　のでしょうか？

 ＞部署名は何かを参照しているのか、=RIGHT(A6,LEN(A6)-FIND("／",A6))という数式？が入っており
 この時のA6セルには、どのようなものが入力されていますか？
 式自体は　A6セルに入力されている文字内で「／」の位置を探しそれより右側の文字を取り出す
 と言った事をやっています。

 案外その他の情報もA6セルに入っていたりしませんか？

 ご提示のサンプルは、１件目のデータだと思います。
 ２件目からも同様に、タイトル−１，データ−１，タイトル−２，データ−２　の様に
 ４行単位で並んでいるのでしょうか？

 まず、エクセルで扱いやすくするために、データを整理するのが良いと思います。
 これは、基本部分をマクロの記録で出来ると思います。

 まずはご提示の表で、データ量が2件の場合で記録を取ります。

 ご提示の例（A:Eの範囲が使ってある表）であれば、
 １．A3:D8を選択
 ２．コピー
 ３．F1セルから貼り付ける。
 ４．J1:J8を選択（表の終わりの次の列の範囲を選択です。）
 ５．=MOD(ROW(A3),4) と入力して、Ctrl + Enter
 ６．オートフィルタを設定
 ７．A2:J8選択
 ８．J列のオートフィルタで「0」以外の項目を表示
 ９．右クリック→行の削除(D)
 10．オートフィルタを解除
 11．結果を表示する項目順に列を移動
 　　　（列を選択して、Shiftを押しながらドラッグすると移動できます。
 　　　　列を切り取り、目的の場所に挿入貼り付け　でもＯＫです。）

 　　　項目はそれぞれで違うと思いますが
 　　　＞\x{fffd}@商品名、\x{fffd}A出庫月、\x{fffd}B部署名、\x{fffd}C出庫量、\x{fffd}D実働使用量
 　　　の順ですかね？
 　　　6列目以降は、今回使うわけではないので　並びは問いません。

 　　　ただ、出庫月・出庫量・実働使用量は、元データ内に直接の値は無いのでしょうか？
 　　　もしかしたら、7番の手順と同じ様に数式を埋め込む必要が
 　　　あるのかもしれないですね？

 12．数式を追加したJ列を削除

 元データを整えるコードの基本部分は完成します。
 後は、完成したコードを開いて少し修正していきます。

 まずは、記録を取って　こちらにコードを載せてみてください。

 このコードの目的は『元データを整える』です。

 パターン分用意しておいて、新しいデータが届いたら
 そのシートをアクティブにして、対応したマクロを実行して使用する目論見です。

 マクロは毎月使うので、マクロ用のブックを一つ用意してそれに入れておくのが良いと思います。
 後で修正しますので、
 　マクロ用のブックと、データが有るブック（コピーしたものを使用して下さい）を開いておいて
 　マクロ用のブックでマクロの記録を開始し
 　データが有るブックをアクティブにしてから
 　１〜12の作業を行って下さい。

 「コードを開いて修正する」と書きましたが、例えば
 ＞１．A3:D8を選択
 の部分なんかは、記録にとると
 Range("A3:D8").Select
 と記録されますが、実際はE列のデータが有る最終行までの範囲を選択する必要が有ります。

 A1:A8に値が入っている状態で
 A20セルをアクティブにして Ctrl + ↑ を押してみてください。
 すると、アクティブセルは A8セルに移動します。
 この動作（Ctrl + ↑）を記録にとると
 　Selection.End(xlUp).Select
 と言うコードが記録されます。

 先の記録とは別に、これも確認してみてください。

 １〜12の記録が出来たらコードを載せてもらえると良いのですが。
 その際、先のサンプルデータが説明の為に小さくしたものだったら
 「説明の為に××にした所は、実際は●●です」と注釈をお願いします。
 また、4行セットでない場合は５番で入れる数式の変更が必要です。
 ＞=MOD(ROW(A3),4)
 「A3」の所は、セット数-1 、「4」の所は、セット数　に変更して下さい。
 たとえば、6行セットだった場合
   =MOD(ROW(A5),6)
 の様に成ります。

 それから、セルの結合等が有る場合はなるべく早く解除しておくのが良いと思います。
 １番の前に、「A1:E8を選択・セルの結合を解除」の作業をして下さい。 

 あと、部署名の所に数式が入っているのも　記録時に問題になるかもしれないですね。
 この行も一行に並ぶように貼り付け作業をして下さい。
 １〜３の手順を繰り返して貰う事になると思います。

 (HANA)

---

 良く考えたら、数式が入っている所は
 1行目を参照しているのでない場合
 他の行は削除してしまうので、エラーになってしまいますね。

 １番の前に、「A1:E8を選択・セルの結合を解除・コピー・値貼付」
 の手順を入れて下さい。　　　　　　　　　　　 ~~~~~~~~~~~~~~

 (HANA)

---

HANAさま　返信おそくなり申し訳ありませんでした。
手順1-12を取り敢えずやってみた結果です。↓
Sub Macro5()
'
' Macro5 Macro
'

'

    Range("A4:P21").Select
    Selection.Copy
    Range("R4").Select
    ActiveSheet.Paste
    ActiveWindow.ScrollColumn = 2
    ActiveWindow.ScrollColumn = 3
    ActiveWindow.ScrollColumn = 4
    ActiveWindow.ScrollColumn = 5
    ActiveWindow.ScrollColumn = 6
    ActiveWindow.ScrollColumn = 7
    ActiveWindow.ScrollColumn = 8
    ActiveWindow.ScrollColumn = 9
    ActiveWindow.ScrollColumn = 10
    ActiveWindow.ScrollColumn = 11
    ActiveWindow.ScrollColumn = 12
    ActiveWindow.ScrollColumn = 13
    ActiveWindow.ScrollColumn = 14
    ActiveWindow.SmallScroll ToRight:=3
    Range("AH3:AH21").Select
    Application.CutCopyMode = False
    Selection.FormulaR1C1 = "=MOD(ROW(R[12]C[-33]),16)"
    Range("AH25").Select
    ActiveWindow.ScrollColumn = 16
    ActiveWindow.ScrollColumn = 15
    ActiveWindow.ScrollColumn = 14
    ActiveWindow.ScrollColumn = 13
    ActiveWindow.ScrollColumn = 12
    ActiveWindow.ScrollColumn = 11
    ActiveWindow.ScrollColumn = 10
    ActiveWindow.ScrollColumn = 9
    ActiveWindow.ScrollColumn = 8
    ActiveWindow.ScrollColumn = 7
    ActiveWindow.ScrollColumn = 6
    ActiveWindow.ScrollColumn = 5
    ActiveWindow.ScrollColumn = 4
    ActiveWindow.ScrollColumn = 3
    ActiveWindow.ScrollColumn = 2
    ActiveWindow.ScrollColumn = 1
    Rows("5:5").Select
    Selection.AutoFilter
    Range("A6:AH21").Select
    ActiveSheet.Range("$A$5:$AH$20").AutoFilter Field:=34, Criteria1:=Array( _
        "10", "11", "12", "13", "14", "15", "2", "3", "4", "5", "6", "7", "8", "9"), Operator:= _
        xlFilterValues
    Columns("X:X").Select
    Selection.Delete Shift:=xlToLeft
    Columns("W:W").Select
    Selection.Delete Shift:=xlToLeft
    Columns("T:V").Select
    Selection.Delete Shift:=xlToLeft
    Columns("AA:AA").Select
    Selection.Delete Shift:=xlToLeft
    Columns("Z:AA").Select
    Selection.Delete Shift:=xlToLeft
    Columns("Z:Z").Select
    Selection.Delete Shift:=xlToLeft
End Sub

実際の元データは、例を挙げたエクセルの表どころではなく、
行と列がまったくランダムに組まれてしまっている状態です。
（出庫数という項目名のしたに実際の数値があるのではなく、なぜか２列あけて次の列に入っているなど。）

 A　　　　BC　　　　D　　　　E
 ----------------------------------------
 出庫数　
 ----------------------------------------
 　　　　　　　　　 7←これが出庫数
 ----------------------------------------　とか、

 A　　　　BC　　　D　　　　E　　　F　　　GH
 ------------------------------------------------
 薬品名称　　　　　　　　　　　　　　　　規格
 ------------------------------------------------
 サニサーラ　　　　　　　　　　　　　　　500ml
 ------------------------------------------------とか…。
教えていただいた方法を、これにどのように当てはめればいいのかわからず、
マクロを実施しても必要なデータにすることができず（T-T)。すみませぬ。

項目数が5に対して、使用している列が全部で16あります。
たぶん、印刷した時の見栄えがいいのだと思いますが、列の幅も大小様々です。
セルの統合をしている部分はありません。
そして一行（1列）で完結している項目もありません。
出庫年月日は、表の1番上に記載されていますが、病棟別には入力されていません。
いらない列をすべて削除し、必要な項目名を改めて入力する方法で、
各商品別に項目をすべて合わせて1年分データをまとめた次第です。↓
Sub Macro6()
'
' Macro6 Macro
'

'

    Rows("1:6").Select
    Selection.Delete Shift:=xlUp
    Range("H1").Select
    Selection.Cut Destination:=Range("I1")
    Range("B1").Select
    ActiveCell.FormulaR1C1 = "部署"
    With ActiveCell.Characters(Start:=1, Length:=2).Font
        .Name = "ＭＳ Ｐゴシック"
        .FontStyle = "標準"
        .Size = 10
        .Strikethrough = False
        .Superscript = False
        .Subscript = False
        .OutlineFont = False
        .Shadow = False
        .Underline = xlUnderlineStyleNone
        .ColorIndex = xlAutomatic
        .TintAndShade = 0
        .ThemeFont = xlThemeFontNone
    End With
    ActiveCell.Characters(1, 2).PhoneticCharacters = "ブショ"
    Range("A:A,C:H,J:P").Select
    Range("J1").Activate
    Selection.Delete Shift:=xlToLeft
    Range("C1").Select
    ActiveCell.FormulaR1C1 = "使用量"
    With ActiveCell.Characters(Start:=1, Length:=3).Font
        .Name = "ＭＳ Ｐゴシック"
        .FontStyle = "標準"
        .Size = 10
        .Strikethrough = False
        .Superscript = False
        .Subscript = False
        .OutlineFont = False
        .Shadow = False
        .Underline = xlUnderlineStyleNone
        .ColorIndex = xlAutomatic
        .TintAndShade = 0
        .ThemeFont = xlThemeFontNone
    End With
    ActiveCell.Characters(1, 3).PhoneticCharacters = "シヨウリョウ"
    Range("D1").Select
    ActiveCell.FormulaR1C1 = "商品名"
    With ActiveCell.Characters(Start:=1, Length:=3).Font
        .Name = "ＭＳ Ｐゴシック"
        .FontStyle = "標準"
        .Size = 10
        .Strikethrough = False
        .Superscript = False
        .Subscript = False
        .OutlineFont = False
        .Shadow = False
        .Underline = xlUnderlineStyleNone
        .ColorIndex = xlAutomatic
        .TintAndShade = 0
        .ThemeFont = xlThemeFontNone
    End With
    ActiveCell.Characters(1, 3).PhoneticCharacters = "ショウヒンメイ"
    Range("D2").Select
    ActiveCell.FormulaR1C1 = "サニサーラ"
    With ActiveCell.Characters(Start:=1, Length:=5).Font
        .Name = "ＭＳ Ｐゴシック"
        .FontStyle = "標準"
        .Size = 10
        .Strikethrough = False
        .Superscript = False
        .Subscript = False
        .OutlineFont = False
        .Shadow = False
        .Underline = xlUnderlineStyleNone
        .ColorIndex = xlAutomatic
        .TintAndShade = 0
        .ThemeFont = xlThemeFontNone
    End With
    Range("C2").Select
    ActiveCell.FormulaR1C1 = "=RC[-1]*250"
    Range("C2").Select
    Selection.AutoFill Destination:=Range("C2:C14"), Type:=xlFillDefault
    Range("C2:C14").Select
    Range("D2").Select
    Selection.AutoFill Destination:=Range("D2:D14"), Type:=xlFillDefault
    Range("D2:D14").Select
    Range("E19").Select
End Sub
こんな感じのことをやって、それをマクロ登録して元データで実行しデータ整理をしました。

＞A1:A8に値が入っている状態で A20セルをアクティブにして Ctrl + ↑

 →これは、やってみましたがアクティブセルが、３つほど上にあがりましたが他はなにも起きませんでした。

データの整理は、こんな感じならば毎月やれそうな感じがします。
次は、この商品別のデータを、部署別に一覧表にする方法でしょうか？
よろしくお願いいたします。

---

 今作ってもらおうとしているマクロは

 現在印刷レイアウトの関係で
          [A]        [B]            [C]           [D]
 　1   【見出し1】
 　2                               データ1-1
 　3              【見出し2】    【見出し3】
   4                データ1-2                    データ1-3
 　5   【見出し1】
 　6                               データ2-1
 　7              【見出し2】    【見出し3】
   8                データ2-2                    データ2-3
 の様になっているものを
       [A]         [B]         [C]
   1　見出し-1    見出し-2    見出し-3
 　2　データ1-1   データ1-2   データ1-3
 　3　データ2-1   データ2-2   データ2-3
 　4　データ3-1   データ3-2   データ3-3
 の様に配置を整えるのが目的です。

 この作業は送られてくるシートのレイアウトは同じだと思うので
 毎回同じ作業を繰り返すことになると思います。

 もしも「同じ商品でもレイアウトは毎回少しずつ違う」と言う場合は
 記録マクロでの対応は困難ですので、別の方法を考えた方がよさそうです。

 ちなみに、商品毎にシートが分かれているという事ですが
 それぞれのレイアウトは同じなのでしょうか？違うのでしょうか？

 ＞必要な項目名を改めて入力する方法
 で、データを整理してもらうと良いと思います。
 ただ、現在いらない情報でも　今後必要になるかもしれませんので
 それは削除するのではなく、列の最後に固めておいてもらうと良いと思います。
 （A:Dが必要な列で、E列以降は今回不要な列・・・って感じで）

 Macro6でC2セルに入れた式は、日付を参照するものでしょうか？

 ＞教えていただいた方法を、これにどのように当てはめればいいのかわからず、
 実際にどの様なものを相手にしているのかこちらからは見えないので
 「○○な感じで〜」としか書きにくい状況です。

 ・項目名のすぐ下にデータがあるわけではない
 と言う事は分かりました。
 行方向のもう少し詳細なレイアウトを教えて下さい。

 一つのシートに、何件かのデータが入っているのですよね？
 1件目が何行目から始まっていて
 2件目は何行目から始まっているのでしょう？

 もう一度↑のサンプルを例にして、イメージを書いてみます。
 元データ
          [A]        [B]            [C]           [D]
 　1   【見出し1】
 　2                               データ1-1
 　3              【見出し2】    【見出し3】
   4                データ1-2                    データ1-3
 　5   【見出し1】
 　6                               データ2-1
 　7              【見出し2】    【見出し3】
   8                データ2-2                    データ2-3

 A3:D8をコピーして、E1から張り付け
 （この例ではA3:A4にデータが無いので、B3からコピーでも良いのですが。。。）
          [A]        [B]            [C]           [D]           [E]           [F]           [G]           [H]
 　1   【見出し1】                                                         【見出し2】    【見出し3】
 ★2                               データ1-1                                 データ1-2                    データ1-3
 　3              【見出し2】    【見出し3】                 【見出し1】
   4                データ1-2                    データ1-3                                 データ2-1
 　5   【見出し1】                                                         【見出し2】    【見出し3】
 ★6                               データ2-1                                 データ2-2                    データ2-3
 　7              【見出し2】    【見出し3】
   8                データ2-2                    データ2-3
 すると、2行目と6行目に　複数行に分かれていたデータが1行になった行が現れます。
 そこで、1行目の見出しを整えます。（必要な所に必要な見出しを入力）
          [A]        [B]            [C]           [D]           [E]           [F]           [G]           [H]
 ★1   【見出し1】               【見出し1】                               【見出し2】    【見出し3】   【見出し3】
 ★2                               データ1-1                                 データ1-2                    データ1-3
 　3              【見出し2】    【見出し3】                 【見出し1】
   4                データ1-2                    データ1-3                                 データ2-1
 　5   【見出し1】                                                         【見出し2】    【見出し3】
 ★6                               データ2-1                                 データ2-2                    データ2-3
 　7              【見出し2】    【見出し3】
   8                データ2-2                    データ2-3

 A,E列はデータが無い列で、B列のデータはF列に。D列のデータはH列にコピー済。G列のデータはC列にあるので
 A,B,D,E,G列は削除します。
          [A]        [B]            [C]           [D]           [E]           [F]           [G]           [H]
 ★1   【見出し1】 【見出し2】    【見出し3】
 ★2     データ1-1   データ1-2      データ1-3
 　3   【見出し3】
   4 
 　5               【見出し2】 
 ★6     データ2-1   データ2-2      データ2-3
 　7   【見出し3】
   8 
 D1:D8に数式をいれて、オートフィルタで絞り込んで削除すると、1,2,6行目だけが残って
          [A]        [B]            [C]           [D]           [E]           [F]           [G]           [H]
 　1   【見出し1】 【見出し2】    【見出し3】
 　2     データ1-1   データ1-2      データ1-3
 　3     データ2-1   データ2-2      データ2-3
   4 
 　5               
 　6    
 　7   
   8 
 になります。

 ＞いらない列をすべて削除し、必要な項目名を改めて入力する方法で、 
 ＞各商品別に項目をすべて合わせて1年分データをまとめた次第です。↓
 って事は、ここまで（のマクロ）は出来たって事ですか？

 ちなみに、↑を記録にとると
Sub Macro1()
'
' Macro1 Macro
'

'

    Range("A3:D8").Select
    Selection.Copy
    Range("E1").Select
    ActiveSheet.Paste
    Application.Left = 340
    Application.Top = 109.75
    Range("C1").Select
    Application.CutCopyMode = False
    ActiveCell.FormulaR1C1 = "【見出し1】"
    ActiveCell.Characters(2, 2).PhoneticCharacters = "ミダ"
    Range("H1").Select
    ActiveCell.FormulaR1C1 = "【見出し3】"
    ActiveCell.Characters(2, 2).PhoneticCharacters = "ミダ"
    Range("A:B,D:E,G:G").Select
    Range("G1").Activate
    Selection.Delete Shift:=xlToLeft
    Range("D1:D8").Select
    Selection.FormulaR1C1 = "=MOD(ROW(R[2]C[-3]),4)"
    Selection.AutoFilter
    Rows("2:8").Select
    ActiveSheet.Range("$D$1:$D$8").AutoFilter Field:=1, Criteria1:=Array("1", _
        "2", "3"), Operator:=xlFilterValues
    Selection.Delete Shift:=xlUp
    Selection.AutoFilter
    Columns("D:D").Select
    Selection.Delete Shift:=xlToLeft
End Sub

 こんな感じになります。

 同じデータをつくって、上記コードを張り付けて結果を確認してみて下さい。

 ＞＞A1:A8に値が入っている状態で A20セルをアクティブにして Ctrl + ↑ 
 ＞→これは、やってみましたがアクティブセルが、３つほど上にあがりましたが他はなにも起きませんでした。

 ３つほど上ののセルにデータが入っていましたよね？
 Ctrl + ↑は、データがある最後のセルに移動出来ます。
 　　　　　（この表現では、少し語弊があるのですが。。。）

 上のサンプルでは、B,D列が一番したまでデータが入っている列になります。
 たとえば、B列の一番下のセルをアクティブにして、Ctrl + ↑　をすると
 アクティブセルは B8セルに移動します。

 もしも、データ件数が３件あって、B13セルまで入力があったとすると
 B列の一番下のセルをアクティブにして、Ctrl + ↑　をすると
 アクティブセルは B13セルに移動します。

 Macro1で記録されているセル番地の内8行目を表す「8」と言う部分は
 13行目まで入力があった場合「13」になってもらいたいし
 37行目まで入力があったら「37」になってもらいたい部分です。

 毎回数字を書き換えるのは大変なので、
 　マクロ内で　Ctrl + ↑で、最終行を取得して コードに組み込もう
 と言う野望を抱きましょう。

    Dim 最終行 As Long
    最終行 = Range("B" & Rows.Count).End(xlUp).Row

 これで、「最終行」と言う変数に、B列の入力がある最後の行数が入ります。
 これも踏まえてMacro1をもうすこし整理すると
Sub Macro2()
'
' Macro2 Macro
'
    Dim 最終行 As Long
    最終行 = Range("B" & Rows.Count).End(xlUp).Row

    Range("A3:D" & 最終行).Copy
    Range("E1").Select
    ActiveSheet.Paste
    Range("C1").FormulaR1C1 = "【見出し1】"
    Range("H1").FormulaR1C1 = "【見出し3】"
    Range("A:B,D:E,G:G").Delete Shift:=xlToLeft
    Range("D1:D" & 最終行).Select
    Selection.FormulaR1C1 = "=MOD(ROW(R[2]C[-3]),4)"
    Selection.AutoFilter
    Rows("2:" & 最終行).Select
    ActiveSheet.Range("$D$1:$D$" & 最終行).AutoFilter Field:=1, Criteria1:=Array("1", _
        "2", "3"), Operator:=xlFilterValues
    Selection.Delete Shift:=xlUp
    Selection.AutoFilter
    Columns("D:D").Select
    Selection.Delete Shift:=xlToLeft
End Sub

 になります。

 件数を増やしたり減らしたりしても、目的の結果が得られることを確認して下さい。

 たぶん「なぜその操作をするのか」がわかれば応用が出来ると思うので
 そのあたりも想像してみてもらえると良いと思います。
 最終的には、1行目に見出しがあって　以降に、1件1行でデータがある表
 が完成出来るなら、途中経過はどのようになっていても関係ないので。

 マクロ実行のひと手間でデータ整理が済めば
 手間も少なくて済むと思います。

 もちろん「ここは手作業でしても苦にならないから良いよ」って事なら
 次へ進みたいと思います。

 コードを作りますのでデータ整理後の見出しの配列と
 ブック内でのシートの順番を教えて下さい。

 (HANA)

---

HANAさま
HANAさまに頂いたMacro２を実行すると、なぜか8行のみになってしまいます。（実際には30行前後はあるのですが）

    Dim 最終行 As Long
    最終行 = Range("B" & Rows.Count).End(xlUp).Row
の部分は、Bの列の最終行までカウントしてね、とういう意味でしょうか？
Bには、部署名が入っていますので、確かにB列を最終行までカウントしてもらえば、全部出力されるはずなのですが、どう対処すれば良いのかわからずすみません。
ちょっと手直ししましたが、下記のような感じのことをすると欲しい表になります。
Sub データ整理()
'
' データ整理 Macro
'

'

    Columns("A:B").Select
    Selection.Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
    Range("F6").Select　→ここに商品名が入力されています
    Selection.Copy
    Range("A8").Select
    ActiveSheet.Paste
    Range("E4").Select　→ここに出庫月が入力されています
    Application.CutCopyMode = False
    Selection.Copy
    Range("B8").Select
    ActiveSheet.Paste
    Rows("1:6").Select
    Application.CutCopyMode = False
    Selection.Delete Shift:=xlUp
    Range("C:C,E:J,L:R").Select
    Range("L1").Activate
    Selection.Delete Shift:=xlToLeft
    Range("A1").Select
    ActiveCell.FormulaR1C1 = "商品名"
    With ActiveCell.Characters(Start:=1, Length:=3).Font
        .Name = "ＭＳ Ｐゴシック"
        .FontStyle = "標準"
        .Size = 10
        .Strikethrough = False
        .Superscript = False
        .Subscript = False
        .OutlineFont = False
        .Shadow = False
        .Underline = xlUnderlineStyleNone
        .ColorIndex = xlAutomatic
        .TintAndShade = 0
        .ThemeFont = xlThemeFontNone
    End With
    ActiveCell.Characters(1, 3).PhoneticCharacters = "ショウヒンメイ"
    Range("B1").Select
    ActiveCell.FormulaR1C1 = "出庫月"
    With ActiveCell.Characters(Start:=1, Length:=3).Font
        .Name = "ＭＳ Ｐゴシック"
        .FontStyle = "標準"
        .Size = 10
        .Strikethrough = False
        .Superscript = False
        .Subscript = False
        .OutlineFont = False
        .Shadow = False
        .Underline = xlUnderlineStyleNone
        .ColorIndex = xlAutomatic
        .TintAndShade = 0
        .ThemeFont = xlThemeFontNone
    End With
    ActiveCell.Characters(1, 2).PhoneticCharacters = "シュッコ"
    ActiveCell.Characters(3, 1).PhoneticCharacters = "ツキ"
    Range("C1").Select
    ActiveCell.FormulaR1C1 = "部署"
    With ActiveCell.Characters(Start:=1, Length:=2).Font
        .Name = "ＭＳ Ｐゴシック"
        .FontStyle = "標準"
        .Size = 10
        .Strikethrough = False
        .Superscript = False
        .Subscript = False
        .OutlineFont = False
        .Shadow = False
        .Underline = xlUnderlineStyleNone
        .ColorIndex = xlAutomatic
        .TintAndShade = 0
        .ThemeFont = xlThemeFontNone
    End With
    ActiveCell.Characters(1, 2).PhoneticCharacters = "ブショ"
    Range("D1").Select
    ActiveCell.FormulaR1C1 = "出庫数"
    With ActiveCell.Characters(Start:=1, Length:=3).Font
        .Name = "ＭＳ Ｐゴシック"
        .FontStyle = "標準"
        .Size = 10
        .Strikethrough = False
        .Superscript = False
        .Subscript = False
        .OutlineFont = False
        .Shadow = False
        .Underline = xlUnderlineStyleNone
        .ColorIndex = xlAutomatic
        .TintAndShade = 0
        .ThemeFont = xlThemeFontNone
    End With
    ActiveCell.Characters(1, 2).PhoneticCharacters = "シュッコ"
    ActiveCell.Characters(3, 1).PhoneticCharacters = "スウ"
    Range("E1").Select
    ActiveCell.FormulaR1C1 = "使用量"
    With ActiveCell.Characters(Start:=1, Length:=3).Font
        .Name = "ＭＳ Ｐゴシック"
        .FontStyle = "標準"
        .Size = 10
        .Strikethrough = False
        .Superscript = False
        .Subscript = False
        .OutlineFont = False
        .Shadow = False
        .Underline = xlUnderlineStyleNone
        .ColorIndex = xlAutomatic
        .TintAndShade = 0
        .ThemeFont = xlThemeFontNone
    End With
    ActiveCell.Characters(1, 3).PhoneticCharacters = "シヨウリョウ"
    Range("E2").Select
    ActiveCell.FormulaR1C1 = "=250*RC[-1]"　→ここは使用量を出すために250mlを出庫数にかけています。
    Range("E2").Select　
    Selection.AutoFill Destination:=Range("E2:E30"), Type:=xlFillDefault　→商品名をコピーしています
    Range("E2:E30").Select
    Range("A2").Select
    Selection.AutoFill Destination:=Range("A2:A30"), Type:=xlFillDefault　→出庫月をコピーしています
    Range("A2:A30").Select
    Range("B2").Select
    Selection.AutoFill Destination:=Range("B2:B30"), Type:=xlFillDefault
    Range("B2:B30").Select
End Sub
これで、下記のような表になる感じです。
A       　 B       C        D        E
　商品名　　出庫月　　部署　　出庫数　　使用量
1　ｻﾆｻｰﾗ　　5/1-5/31　　○　　　　2　　　500　
2　ｻﾆｻｰﾗ　　5/1-5/31　　□　　　　4　　　1000
3　ｻﾆｻｰﾗ　　5/1-5/31　　▲　　　　2　　　500　…
しかし、こんなに長いマクロが、HANAさまのMacro２のようにシンプルになるんですね。すごいです！
現在は、上記の表形式で物品別に1年分のデータを入れるところまできました。
この次は、別々のシート（物品別）にある５つの項目を、部署別に1シートずつにしていければ、
と思い、とりあえず各物品別に下記のようなマクロを作成し、sheet1に病棟別にデータを集めるようなことをやっております。
Sub サニサ250コピー()
'
' サニサ250コピー Macro
'

'

    Range("A1:E40").Select
    Selection.SpecialCells(xlCellTypeVisible).Select
    Application.CutCopyMode = False
    Selection.Copy
    Sheets("Sheet1").Select
    Range("F1").Select
    ActiveSheet.Paste
    Range("K1").Select
End Sub
どこからどこまでコピーするように、というオーダーをどうすれば良いかがわからないので、部署名と物品名でフィルタしたあと、
\x{fffd}@最大行になるであろうところまで可視セルのみコピーしてSheet１に貼付け、
\x{fffd}A全データがそろったらシートをコピーしシート名を部署名に変える（ここは完璧に手作業です）、といった手順でしょうか。
無駄な動作がすごく多くて、ウンザリするのですが、自力ではこのあたりが限度でした。

＞コードを作りますのでデータ整理後の見出しの配列と ブック内でのシートの順番を教えて下さい。
見出しの配列は、\x{fffd}@商品名\x{fffd}A出庫月\x{fffd}B部署\x{fffd}C出庫数\x{fffd}D使用量です。
シートの順番は、A5,NICU,A6,A7,B3,EICU,B4,B5,B6,C2,C3,C4,C5,E4,W5,WC,ER,HD,外来（30外来ありますが、とりあえず）、化学療法、OPです。
よろしくお願いいたします。（Machi)

---

 もしかして、元の表は

 −−−−−−−−−−−−−−−−−−−−−−−−−−−−−−−
 １　　薬品コード　　薬品名称　　　　　　　　規格　　　包装数　
 −−−−−−−−−−−−−−−−−−−−−−−−−−−−−−−
 ２　　サニサ40　　　サニサーラ　　　　　　　250ｍｌ　　１  
 −−−−−−−−−−−−−−−−−−−−−−−−−−−−−−−
 ３　　部署　　　　出庫数　　　出庫返品数　　出庫実働数…　　
 −−−−−−−−−−−−−−−−−−−−−−−−−−−−−−−
 ４　　あ　　　　　　46　　　　　　1　　　　　45
 −−−−−−−−−−−−−−−−−−−−−−−−−−−−−−−
 ５　　い　　　　　　20            1          19
 −−−−−−−−−−−−−−−−−−−−−−−−−−−−−−−
 ６　　う　　　　　　35            0          35
 −−−−−−−−−−−−−−−−−−−−−−−−−−−−−−−
 って感じで、データ自体はリストになっているのですか？
 でしたら、話が通じなくて当然ですね。。。

 とりあえず、ご呈示の「データ整理」コードは、以下の様にできると思います。

 '------
Sub データ整理2()
    Dim mxR As Long

    Columns("A:B").Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
    Range("A8").Value = Range("F6").Value   '→F6(元のD6)に商品名が入力されています
    Range("B8").Value = Range("E4").Value   '→E4(元のC4)に出庫月が入力されています

    Rows("1:6").Delete Shift:=xlUp
    Range("C:C,E:J,L:R").Delete Shift:=xlToLeft
    Range("A1").Value = "商品名"    
    Range("B1").Value = "出庫月"    
    Range("C1").Value = "部署"
    Range("D1").Value = "出庫数"
    Range("E1").Value = "使用量"

    mxR = Range("D" & Rows.Count).End(xlUp).Row

    Range("E2:E" & mxR).FormulaR1C1 = "=250*RC[-1]" '→ここは使用量を出すために250mlを出庫数にかけています。

    Range("A2:A" & mxR).Value = Range("A2")         '→商品名をコピー
    Range("B2:B" & mxR).Value = Range("B2")         '→出庫月をコピー
End Sub
 '------

 ＞最終行 = Range("B" & Rows.Count).End(xlUp).Row
 ＞Bの列の最終行までカウントしてね、とういう意味でしょうか？
 B列の最後に入力されているセルが何行目か教えて（変数：最終行　に入れて）ね。
 と言う意味です。

 ＞シートの順番は、A5,NICU,A6,A7,B3,EICU,B4,B5,B6,C2,C3,C4,C5,E4,W5,WC,ER,HD,外来（30外来ありますが、とりあえず）、化学療法、OPです
 これは元データのシートですよね？

 ＞全データがそろったらシートをコピーしシート名を部署名に変える（ここは完璧に手作業です）、といった手順
 と言う事は、部署ごとのシートは新たに用意するのですね？

 ↓エラーが出るかもしれませんが、確認してみて下さい。
'------
Sub TEST()
    Dim i As Long, shi As Long, MyR As Long
    Dim tbl As Variant
    Dim ws As Worksheet

    For shi = 1 To 22
        If Sheets(shi).Name <> "30外来" Then
            With Sheets(shi)
                tbl = .Range("A1", .Range("E" & Rows.Count).End(xlUp)).Value
            End With
            For i = 2 To UBound(tbl, 1)
                On Error Resume Next
                    Set ws = Worksheets(tbl(i, 3))
                On Error GoTo 0
                If ws Is Nothing Then
                    Sheets.Add(after:=Sheets(Sheets.Count)).Name = tbl(i, 3)
                    Sheets(tbl(i, 3)).Range("A1:E1").Value = Array("商品名", "出庫月", "部署", "出庫数", "使用量")
                End If
                With Sheets(tbl(i, 3))
                    MyR = .Range("A" & Rows.Count).End(xlUp).Row + 1
                    .Range("A" & MyR).Value = tbl(i, 1)
                    .Range("B" & MyR).Value = tbl(i, 2)
                    .Range("C" & MyR).Value = tbl(i, 3)
                    .Range("D" & MyR).Value = tbl(i, 4)
                    .Range("E" & MyR).Value = tbl(i, 5)
                End With
            Next
        End If
    Next
End Sub
'------

 (HANA)

---

HANAさま

お手数をおかけしていてすみません。

＞もしかして、元の表は…
項目名の下に数値が並んでいるわけではありませんが
（2列横にずれて数値が入力されている）、
不要な列を全部削除し、新たに項目名を入力することで、提示されたような表になる感じです。
ちゃんと伝えられず申し訳ありません。

 ＞シートの順番は、A5,NICU,A6,A7,B3,EICU,B…です
 これは元データのシートですよね？
→元データ（業者が提出するデータ）は、物品名別または物品コード別にシートが分かれています。
物品のシート名はｻﾆｻｰﾗ40、ｻﾆｻｰﾗ250、ｻﾆｻｰﾗ500、ｳｪﾙｱｯﾌﾟ1%、ｳｪﾙｱｯﾌﾟ5%、ﾍﾞﾙｺﾑﾛｰｼｮﾝ、900708(これはできればｳｫｯｼｭﾎﾞﾝGに変更したいです)90709(ｳｫｯｼｭﾎﾞﾝﾋﾟﾝｸ同左)、903488(ﾊﾝﾄﾞｿｰﾌﾟ同左)、903722(ｼｬﾎﾞﾈｯﾄ同左)です。

 ＞全データがそろったらシートをコピーしシート名を部署名に変える…
 と言う事は、部署ごとのシートは新たに用意するのですね？
→はい。これが、＞シートの順番は、A5,NICU,A6,A7,B3,EICU,B…の部分です。
そして、外来に関しては1外来ずつのシートと、全外来一括(30外来分がすべて1つのシートに入る状態)のシートが必要です。
実際に必要となるシート名が、A5,NICU,A6,A7,B3,EICU,B4,B5,B6,C2,C3,C4,C5,E4,W5,WC,ER,HD,外来(ここに30ほどある外来すべてを集約)、化学療法、OPになります。
また、各業者ごとに微妙に部署名の入力方法が違っているため、部署項目をそのまま抜き出すことができません。（例：OPと手術室と中央手術室といった感じに、同じ部署でも業者によって違う言葉で入力されています。）

実際にデータが入ったブックでTESTを実行したところ、以下の部分にエラーがでて、コードが進みませんでした。

 Sheets.Add(after:=Sheets(Sheets.Count)).Name = tbl(i, 3)

また、他の業者のデータを整理するために使用しているマクロは、以下の通りです。
Sub 石鹸データ整理1L()
'
' 石鹸データ整理１L Macro
'

'

    Columns("A:A").Select
    Selection.Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
    Range("B2").Select→ここで商品名をコピーしています。
    Selection.Cut Destination:=Range("A5")
    Columns("C:C").Select
    Selection.Copy
    Columns("D:D").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    Range("B:C,F:G,I:M").Select
    Range("I1").Activate
    Application.CutCopyMode = False
    Selection.Delete Shift:=xlToLeft
    Rows("1:3").Select
    Selection.Delete Shift:=xlUp
    Range("A1").Select
    ActiveCell.FormulaR1C1 = "商品名"
    ActiveCell.Characters(1, 3).PhoneticCharacters = "ショウヒンメイ"
    Range("B1").Select
    ActiveCell.FormulaR1C1 = "部署"
    ActiveCell.Characters(1, 2).PhoneticCharacters = "ブショ"
    Range("C1").Select
    ActiveCell.FormulaR1C1 = "出庫月"
    ActiveCell.Characters(1, 2).PhoneticCharacters = "シュッコ"
    ActiveCell.Characters(3, 1).PhoneticCharacters = "ゲツ"
    Range("D1").Select
    ActiveCell.FormulaR1C1 = "出庫数"
    ActiveCell.Characters(1, 2).PhoneticCharacters = "シュッコ"
    ActiveCell.Characters(3, 1).PhoneticCharacters = "スウ"
    Range("E1").Select
    ActiveCell.FormulaR1C1 = "使用量"
    ActiveCell.Characters(1, 3).PhoneticCharacters = "シヨウリョウ"
    Range("E2").Select
    ActiveCell.FormulaR1C1 = "=RC[-1]*1000"→ここは1000の場合と5000の場合があります。
    Range("E2").Select
    Selection.AutoFill Destination:=Range("E2:E49"), Type:=xlFillDefault
    Range("E2:E49").Select
    ActiveWindow.SmallScroll Down:=-12
    Range("A2").Select
    Selection.AutoFill Destination:=Range("A2:A49"), Type:=xlFillCopy
    Range("A2:A49").Select
    ActiveWindow.SmallScroll Down:=-9
    Range("A1:E1").Select
    Selection.AutoFilter
End Sub

提出期限がせまっているので、とりあえず自分のできる方法でやっていますが、
今後はポチッと数回クリックすれば、一覧表ができるようになりたいので、
引き続きご指導お願いいたします。（Machi)

---

HANAさま　
途中経過なのですが。
石鹸データ整理の部分は、HANAさまの式を参考に以下のように変えてみました。
Sub 石鹸データ整理5L()
'
' 石鹸データ整理5L Macro
'
Dim mxR As Long

    Columns("A:A").Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
    Range("A5").Value = Range("B2").Value  
    Columns("C:C").Select
    Selection.Copy
    Columns("F:F").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False

    Rows("1:3").Delete Shift:=xlUp
    Range("B:D,G:G,I:M").Delete Shift:=xlToLeft
    Range("A1").Value = "商品名"
    Range("B1").Value = "出庫月"
    Range("C1").Value = "部署"
    Range("D1").Value = "出庫数"
    Range("E1").Value = "使用量"

    mxR = Range("D" & Rows.Count).End(xlUp).Row

    Range("E2:E" & mxR).FormulaR1C1 = "=5000*RC[-1]" 

    Range("A2:A" & mxR).Value = Range("A2")         
    Range("B2:B" & mxR).Value = Range("B2")         
End Sub

現在、HANAさまの式で、使用量をかける部分のみ数値を変更して、それぞれの物品別に名前をつけたマクロを作成することろまで出来ました。

---

 ＞＞シートの順番は、A5,NICU,A6,A7,B3,EICU,B…です
 元データじゃないんですね。。。

 ＞外来に関しては1外来ずつのシートと、全外来一括(30外来分がすべて1つのシートに入る状態)のシートが必要です。
 これは、どういった事でしょう？
 A5,NICU,A6,A7・・・とかは部署名なんですよね？
 挙げられているもの以外が外来　って事でしょうか？

 ＞以下の部分にエラーがでて、コードが進みませんでした。 
 ＞Sheets.Add(after:=Sheets(Sheets.Count)).Name = tbl(i, 3)
 どのようなエラーメッセージがでましたか？
 また、tbl(i, 3)のあたりにマウスを持っていくと
 ポップアップみたいなのが表示されて、内容が確認できます。
 何になっていますか？

 ＞各業者ごとに微妙に部署名の入力方法が違っているため、部署項目をそのまま抜き出すことができません。
 これは、同じ業者では同じ書き方をしてくれると思いますので
 対応表を作って、VLOOKUP関数で参照させる様にしてはどうでしょう？

 ＞現在、それぞれの物品別に名前をつけたマクロを作成することろまで出来ました。
 それは良かったです。

 記録でできたコードは、動作が一つずつ記録されますし
 本来必要でない動作も記録されてしまいます。
 上手に直して　つかってもらうと良いと思います。

 ちなみに
    Columns("C:C").Select
    Selection.Copy
    Columns("F:F").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
 の部分は、Select Selection　を縮めると
    Columns("C:C").Copy
    Columns("F:F").PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
 になりますね。

 (HANA)

---

 もしもエラーが
 「インデックスが有効範囲に有りません」
 と言ったものであれば、
 ＞For shi = 1 To 22
 の所を正しい範囲に変更して下さい。

 データシートは、左から数えて  何番目から何番目迄に有るでしょうか？

 (HANA)

---

 ＞提出期限がせまっているので、とりあえず自分のできる方法でやっていますが
 作業はどの程度進んでいますか？
 理想コードが完成するまでの暫定案として
 フィルタオプションの設定を利用するのはどうでしょう？

 元データは一つのシートにまとめる（部署名を統一する）
 フィルタオプションの条件等を入力したシートを用意する
 一番最初は、抽出作業をマクロの記録にとる
 ２番目からは、「部署」のセルを書き換えてマクロを実行
 シート名は自分で変えないといけないですが、１シートずつ１部署ずつ
 オートフィルタを設定して、コピーして・・・　の作業をするより
 時間短縮につながると思います。

 (HANA)

---

HANAさま

＞作業はどの程度進んでいますか？
2012年1月から2013年1月までのデータに関しては、
\x{fffd}@:元データを整理(商品名、出庫月、部署、出庫数、使用量の表にする）。
\x{fffd}A:全期間分として、\x{fffd}@を各物品別にシートに集約。
\x{fffd}B:部署ごとにシートを作成し、そこに\x{fffd}Aのデータを部署別に集約。
\x{fffd}C:\x{fffd}Bのシートで、出庫月ごとにフィルタし、部署ごとに月別使用量として印刷している状態です。

期限が今週水曜日ですので、全て印刷して提出はしました。
今後は、各月毎にデータが渡される予定です。なので、
\x{fffd}@:元データ(物品別のシート)を整理(商品名、出庫月、部署、出庫数、使用量の表にする)。
\x{fffd}A:\x{fffd}@を1つのシートにまとめる。
\x{fffd}B:\x{fffd}Aを部署別にして、印刷する。
といった作業をしていけば良さそうだと考えています。

TESTを実施したときのエラーは以下の通りです。
実行時エラー1004「アプリケーション定義またはオブジェクト定義のエラーです」

何となくおわかりかもしれませんが、Machiは事務職ではありません。
なので、エクセルに関する言葉が曖昧で、伝わりにくいことが多いと思います。
お手数おかけしますが、よろしくお願いします。

---

 急ぎの作業は済んだのですね。御疲れ様でした。

 今後作業自体は、月単位で良いんですよね？

 ＞実行時エラー1004「アプリケーション定義またはオブジェクト定義のエラーです」 
 の時、何回かループしていたら　いくつかシートが作成されていると思いますが
 どの様な状況だったでしょうか？

 テストブックを作成して下さい。
 元データは、３シートくらいにして　左端から並ぶ様にして下さい。
 データ量も多いと大変なので、10行くらいずつに減らして下さい。

 メニューからマクロの実行を行う時　ステップイン(S)　を押してください。
 すると、コードが前面に表示されて、黄色くハイライトされた行があると思います。
 [F8]を押すと、黄色い部分が一つずつ下に下がっていきます。

 どこまで進んでエラーが出るか教えてもらいたいです。
 ちなみに、ローカルウィンドウを表示させると　変数の内容等確認できます。
 それも併用しながら、状況を教えてもらえると良いのですが。

 ＞エクセルに関する言葉が曖昧で、伝わりにくいことが多いと思います。 
 今の所、スムーズに話が進んでいると思います。
 言葉が伝わりにくいのはお互い様だとおもって、こちらもご容赦願います。

 (HANA)

---

HANAさま
＞今後作業自体は、月単位で良いんですよね？
そうなりそうです(事務部が毎月データを渡してくれればですが)。

＞テストブックを作成してください。
元データを3シートにして左端から３つ(物品A、物品B、物品C)並べ、データ量は10前後にしました。

物品Aのシートをアクティブにした状態で
マクロの実行をステップインでF8を押していくと、
まず初めに「部署」というシートを作成し、
続いて物品Aのデータに入っている部署名すべてのシートを作成しました。
それが終わって、さらにもう1周した後に、With Sheets(tbl(i, 3))
「インデックスが有効範囲に有りません」がエラーとして表示されました。
今回は、実行時エラー1004「アプリケーション定義またはオブジェクト定義のエラーです」 は出ませんでした。

＞＞For shi = 1 To 22　 の所を正しい範囲に変更して下さい。
データシートは、左から数えて 何番目から何番目迄に有るでしょうか？
ということは、このテストデータの場合は1　To　3にすれば良いのか？と思い修正して
再度ステップインでやってみましたが、 物品Aの部署名分シートを全て作成した後、
さらにもう1回ループしてから、With Sheets(tbl(i, 3))の部分で
同様のエラーが表示されました。
ローカルウィンドウは開いておいたものの、何がなにやらわからず…。
+ : Module2 : : Module2/Module2

  : i : 3 : Long
  : shi : 2 : Long
  : MyR : 3 : Long

• : tbl : : Variant/Variant(1 to 13, 1 to 5)
• : ws : : Worksheet/Sheet39
このあとはズラズラと出ていてどこを見れば良いのやら…です。
物品Aの部署別シートは出力されますが、物品B,Cへは進まない様子です。(Machi)

---

 あ・・・・もしかして
                If ws Is Nothing Then
                    Sheets.Add(after:=Sheets(Sheets.Count)).Name = tbl(i, 3)
                    Sheets(tbl(i, 3)).Range("A1:E1").Value = Array("商品名", "出庫月", "部署", "出庫数", "使用量")
                End If
 の部分を
                If ws Is Nothing Then
                    Sheets.Add(after:=Sheets(Sheets.Count)).Name = tbl(i, 3)
                    Sheets(tbl(i, 3)).Range("A1:E1").Value = Array("商品名", "出庫月", "部署", "出庫数", "使用量")
                    Set ws = Nothing  '←追加
                End If
 Set ws = Nothing　を忘れてました。（すみません）
 追加して下さい。

 ＞ このテストデータの場合は1　To　3にすれば良いのか？と思い
 はい、書き忘れてましたが、 1 To 3 にして下さい。

 ＞ローカルウィンドウは開いておいたものの、何がなにやらわからず…。 
  : i : 3 : Long
 いま、iの値が「3」と言う事です。
 たとえば　tbl(i, 3)　の所が　tbl(3, 3)　と書いてあるのと同じになります。

 ： tbl : : Variant/Variant(1 to 13, 1 to 5) 
 tblと言う変数が、13行×5列のマス目に分かれていて
 tbl(3, 3)と言うと、3行目で3列目の場所を意味します。

 コードの
 tbl = .Range("A1", .Range("E" & Rows.Count).End(xlUp)).Value
 部分で、tblには、A1セルからE列の最後の行までの値を取り込みました。

 データが13行目まであれば　A1:E13の値が tblに写し取られていると思って下さい。
 3列目は、部署が入っている列ですね。
 3行目に入力されている部署名は何でしょう？
 　・・・・の様に考えてみて下さい。

 ちなみに、
 　tblの所に[+]マークがあると思いますが　それを開くと
 　各位置にどの様な値が入っているか確認できます。
 また、各変数の値や　内容は、コードの該当部分にカーソルを近づけて確認もできます。

  : shi : 2 : Long
 ここも、shiという変数が「2」と言う事です。
 shiが出てくるのは
 ＞If Sheets(shi).Name <> "30外来" Then
 ですね。
 Sheets(2)は、左から数えて2番目のシート　の事です。
 上のコードの意味、
　 左から数えて2番目のシート ・・・Sheets(2)・・・の
 　名前・・・・・・・・・・・・・・.Name・・・・・が
 　「30外来」・・・・・・・・・・・"30外来"・・・と
 　等しくない・・・・・・・・・・・<>・・・・・・場合
 　If 〜 End If の間に書いてある部分を実行する
 です。

 まずは、コードを変更して　もう一度やってみて下さい。

 (HANA) 

---

HANAさま

Set ws = Nothingを追加し、For shi = 1 To 3に修正して、
物品Aのシートをアクティブにして再度ステップインでみていったところ、
同じ場所で、 With Sheets(tbl(i, 3))
「インデックスが有効範囲に有りません」がエラーとして表示されました。

物品Bのシートを先頭にし、シートをアクティブにしてステップインで見ていくと、
「部署」というシートを作成後、4つ目の部署までは作成しましたが、
その後の部署は作成せず(ループだけはしていましたが)最後に、同様のエラーが表示されました。

 物品Bの部署は、Ｃ４, Ｂ４, Ａ７, Ｂ５, Ｃ４, Ｂ４, Ｃ５, Ｃ２, Ａ８, 透析室の順で部署名が入っていますが、実際に作成されたシートは、
部署,Ｃ４, Ｂ４, Ａ７, Ｂ５でした。また、重複している病棟のデータはちゃんと入っていました。
ローカルウィンドウには

• : Module2 : : Module2/Module2

    :  : <変数なし> : 
  : i : 9 : Long
  : shi : 1 : Long
  : MyR : 3 : Long
+ : tbl :  : Variant/Variant(1 to 12, 1 to 5)
  + : tbl(1) :  : Variant(1 to 5)
  + : tbl(12) :  : Variant(1 to 5)
      : tbl(1,1) : Empty 値 : Variant/Empty
      : tbl(1,2) : Empty 値 : Variant/Empty
      : tbl(1,3) : Empty 値 : Variant/Empty
      : tbl(1,4) : Empty 値 : Variant/Empty
      : tbl(1,5) : 5000 : Variant/Double
  - : tbl(2) :  : Variant(1 to 5)
      : tbl(2,1) : "商品名" : Variant/String
      : tbl(2,2) : "年月日" : Variant/String
      : tbl(2,3) : "部署" : Variant/String
      : tbl(2,4) : "払出数" : Variant/String
      : tbl(2,5) : "使用量" : Variant/String
  - : tbl(3) :  : Variant(1 to 5)
      : tbl(3,1) : "ピンク" : Variant/String
      : tbl(3,2) : "H 24.03.31" : Variant/String
      : tbl(3,4) : 1 : Variant/Double
      : tbl(3,5) : 5000 : Variant/Double　→この後tb(12)まで、すべての部署名分同様にあり

• : ws : : Worksheet/Sheet6

  + : Application :  : Application/Application
    : AutoFilter : Nothing : AutoFilter
  + : Cells :  : Range/Range　（以下は抜粋です）
      : Count : <アプリケーション定義またはオブジェクト定義のエラーです。> : Long
  + : ListObjects :  : ListObjects/ListObjects
      : CurrentArray : <該当するセルが見つかりません。> : Range
      : Dependents : <該当するセルが見つかりません。> : Range
    : MailEnvelope : <アプリケーション定義またはオブジェクト定義のエラーです。> : MsoEnvelope
    : Name : " Ｂ４" : String
WSの＋を開こうとするとOutlookの設定を求められ、それをキャンセルするとズラズラと展開される感じです。

物品Aのシートの部署はすべて違う部署名ですが、物品Bのシートの部署は同じものがいくつか混ざっている状態です。
よろしくお願いいたします。

---

HANAさま
あともう１つ気が付いたことがあります。
物品AのシートでTESTを実行した場合、作成されるシートタブが通常の４倍くらいの大きさになります。物品B・Cでは、通常のタブの大きさです。
例）(B6)と(B6　　　　　　)という感じです。

---

 たびたびすみません。
 修正箇所が間違ってました。。。

                If ws Is Nothing Then
                    Sheets.Add(after:=Sheets(Sheets.Count)).Name = tbl(i, 3)
                    Sheets(tbl(i, 3)).Range("A1:E1").Value = Array("商品名", "出庫月", "部署", "出庫数", "使用量")
                    Set ws = Nothing  '←追加
                End If
 ではなく
                If ws Is Nothing Then
                    Sheets.Add(after:=Sheets(Sheets.Count)).Name = tbl(i, 3)
                    Sheets(tbl(i, 3)).Range("A1:E1").Value = Array("商品名", "出庫月", "部署", "出庫数", "使用量")
                Else                  '←これを追加して
                    Set ws = Nothing  '←ここに入れる
                End If
 でした。

 それと、タイトル行が2行目で　データが3行目の様なので
             For i = 2 To UBound(tbl, 1)
 の所は　i = 3　から始めてください。

 「部署」ってシートが作られなくなると思います。

 それから
         If Sheets(shi).Name <> "30外来" Then
 は、思い違いだったのでいらないのですが
 それに対応する End If も一緒にいらなくなります。

 と、言う事で　なんら新しい事は無いですが　一旦コードを再ＵＰしますね。

 '------
Sub TEST2()
    Dim i As Long, shi As Long, MyR As Long
    Dim tbl As Variant
    Dim ws As Worksheet

    For shi = 1 To 1
        With Sheets(shi)
            tbl = .Range("A1", .Range("E" & Rows.Count).End(xlUp)).Value
        End With
        For i = 3 To UBound(tbl, 1)
            On Error Resume Next
                Set ws = Worksheets(tbl(i, 3))
            On Error GoTo 0
            If ws Is Nothing Then
                Sheets.Add(after:=Sheets(Sheets.Count)).Name = tbl(i, 3)
                Sheets(tbl(i, 3)).Range("A1:E1").Value = Array("商品名", "出庫月", "部署", "出庫数", "使用量")
            Else
                Set ws = Nothing
            End If
            With Sheets(tbl(i, 3))
                MyR = .Range("A" & Rows.Count).End(xlUp).Row + 1
                .Range("A" & MyR).Value = tbl(i, 1)
                .Range("B" & MyR).Value = tbl(i, 2)
                .Range("C" & MyR).Value = tbl(i, 3)
                .Range("D" & MyR).Value = tbl(i, 4)
                .Range("E" & MyR).Value = tbl(i, 5)
            End With
        Next
    Next
End Sub
 '------

 ＞例）(B6)と(B6　　　　　　)という感じです。
 の例を見ると、後ろにスペースが入っていて
 大きく成っている様に感じますが。。。そうなのでしょうか？
 それとも、他の所とフォントが違うとかそういった事でしょうか。。。？

 (HANA)

---

HANAさま

すごいですー!!
ポチッと押すだけで、全部のデータを書き出してくれました。

＞例）(B6)と(B6　　　　　　)という感じです。
＞の例を見ると、後ろにスペースが入っていて

 大きく成っている様に感じますが。。。そうなのでしょうか？
→はい、その通りです。
なぜか、このシート(物品A)の項目は、タブが通常の４倍くらいの長さになってしまいます。
他のシートは、通常通り文字数に合わせた大きさなのですが。
シートのデータ書式はすべて同じでMSPゴシックです。（Machi)

---

HANAさま

あと2つお聞きしたいことがあるのですが、
例えば外科とか内科といったように「科」という字が入っているセルの文字を、
すべて「外来」に変更する、とか
あらかじめ指定した文字の場合に、それを全て「外来」に変更する
といったことはできるものなのでしょうか？

科別(30種類の診療科)になっているデータを、「外来」として１つに集約しなければならないのですが、
外来名はすべて違うため、TEST２のマクロをポチッとする前に、
部署名(手術室とOPと中央手術室みたいなものも含めて)を整えたいと考えています。が！
＞対応表を作って、VLOOKUP関数で参照させる様にしてはどうでしょう？
きっとこの関数を使えばいいのだろうな…と思いつつ、
関数のヘルプを読んではみたのですが、何を言われているのかさっぱりわからず(T-T)。
現在は、置換を使用してポチポチ１つずつ変更しています。

もう１つは、今後の動きの中の、\x{fffd}Aに関してです。
\x{fffd}@:元データ(物品別のシート)を整理(商品名、出庫月、部署、出庫数、使用量の表にする)。
\x{fffd}A:\x{fffd}@を1つのシートにまとめる。
→現在は、１シート(物品)ごとにコピーして、データが重ならないようにするために、
物品AのデータをA(物品名),B(出庫月),C(部署),D(出庫数),E(使用量)に入れたら、
物品BのデータはF(物品名),G(出庫月),H(部署),I(出庫数),J(使用量)……という感じに横に張付けていくスタイルです。
最後に手作業でSheet１のデータを縦の一表にまとめています。
コピーの部分は以下のマクロを記録してやっています。
Sub サニサ250コピー()
'
' サニサ250コピー Macro

    Dim 最終行 As Long
    最終行 = Range("C" & Rows.Count).End(xlUp).Row

    Range("A1:E" & 最終行).Select
    Selection.SpecialCells(xlCellTypeVisible).Select
    Application.CutCopyMode = False
    Selection.Copy
    Sheets("Sheet1").Select
    Range("A1").Select　→ここで張付けるセルを選んでます。
    ActiveSheet.Paste
End Sub
Sub サニサ500コピー()

' サニサ500コピー Macro

    Dim 最終行 As Long
    最終行 = Range("C" & Rows.Count).End(xlUp).Row

    Range("A1:E" & 最終行).Select
    Selection.SpecialCells(xlCellTypeVisible).Select
    Application.CutCopyMode = False
    Selection.Copy
    Sheets("Sheet1").Select
    Range("Ｆ1").Select　→今度は重ならない位置のF1を選択してます。
    ActiveSheet.Paste
End Sub

 Range("A1:E" & 最終行).Selectみたいに、
データが重ならないよう「最終行から張付け開始」といった方法はあるのでしょうか？（Machi)

---

 ＞＞後ろにスペースが入っていて 
 ＞＞大きく成っている様に感じますが。。。そうなのでしょうか？
 ＞→はい、その通りです。
 部門別の新しいシートの名前は
 　　Sheets.Add(after:=Sheets(Sheets.Count)).Name = tbl(i, 3)
 この部分で付けています。

 Sheets(2)で左から2番目のシートを表しますが
 Sheets(Sheets.Count)で、一番最後のシートを表せます。
        ~~~~~~~~~~~~これが、「ブック内のシートをカウントした数」だからです。
 ですから、先の一行は
 　　シート・・・・・・・・Sheets・・・・・・・・・・を
 　　一番最後のシート・・・Sheets(Sheets.Count)・・・の
 　　後ろ・・・・・・・・・after:= ・・・・・・・・・に
 　　追加・・・・・・・・・.Add
 　　名前を・・・・・・・・.Name
     tbl(i, 3)にする
 です。

 ステップインで実行中も、この行を抜けた時　シートが追加されるのが確認出来ると思います。

 物品Aのシートの部署名の部分に　きっとスペースが入っているのだと思います。

 マクロでスペースを削除する方法や↓と同じ手段を使う方法や　手作業で対応する方法等
 色々なやり方があると思いますので、どの様にするのが良いか考えてみて下さい。

 とりあえず↓から
 ＞科別(30種類の診療科)になっているデータを、「外来」として１つに集約しなければならないのですが

 簡単な例を挙げてみます。
 	[A]	[B]	[C]	[D]	[E]
[1]	動物名	シート		動物名	シート
[2]	いぬ	いぬ		さる	さる
[3]	さる	さる		いぬ	いぬ
[4]	ねこ	不明		きじ	とり
[5]	きじ	とり		はと	とり
[6]	はと	とり		たか	とり
[7]	たか	とり			

 D1:E6に対応表を作ります。
 D列に部署名、E列にまとめるシートの名前（統一後の名前）を一覧にします。

 A列が、物品別のシートの部署名の列だと思ってください。
 B列に　=IF(COUNTIF($D$2:$D$6,A2),VLOOKUP(A2,$D$2:$E$6,2,FALSE),"不明")

 部署ごとに分ける時、今は部署名の列(A列)を使って分けるので　
 　いぬシート、さるシート、ねこシート、きじシート、はとシート、たかシートが出来ますが
 シート名の列(B列)を使って分ける事にすると、
 　いぬシート、さるシート、不明シート、とりシート　に分かれる事になります。

 イメージがわかりますか？

 物品Aの部署名の件も、VLOOKUP関数で済ませようとする場合は　D列にさらに
 　さる＿＿＿＿　←後ろにスペースを付けて　物品Aに入力されているものと同じにしたセル
 を増やしたらどうかと思っています。

 ただし、他の場所でもスペースが入っている可能性がありますので
 問題が無ければ、スペースを一括削除（置換）する事にした方が良いのかもしれません。

 マクロは今、どのブックに入っていますか？
 同じブック（マクロブック）に対応表を作成してもらうと良いと思います。

 ＞Range("A1:E" & 最終行).Selectみたいに、
 ＞データが重ならないよう「最終行から張付け開始」といった方法はあるのでしょうか？
 コードを作る時に、書替が必要な部分に着目して下さい。
 今回は
 ＞Range("A1").Select　→ここで張付けるセルを選んでます。
 ここの所を書き換えていますよね？

 なので「あ〜、A列の入力がある最後のセルの一つ下のセルがわかればいいのに」と思って下さい。

 少し上の方に戻りますが
 ＞＞最終行 = Range("B" & Rows.Count).End(xlUp).Row
 ＞＞Bの列の最終行までカウントしてね、とういう意味でしょうか？
 ＞B列の最後に入力されているセルが何行目か教えて（変数：最終行　に入れて）ね。
 ＞と言う意味です。
 この部分、もう少し詳しく書いておけばよかったですね。

 Rows.Count は、シート全体の行数です。xlsだったら65536行目まであるので 65536　です
 Range("B" & Rows.Count)　は　Range("B65536") と書いてある事になります。

 そこから　.End(xlUp) ＝ Ctrl + ↑　で移動したセル　の行番号が知りたければ
 後ろに　.Row　を付けますし、選択(Select)するなら
 　　Range("B" & Rows.Count).End(xlUp).Select
 こんな記述になります。

 アクティブシートの最終行までの範囲を、Sheet1の続きに貼りつけるなら
    Dim 最終行 As Long
    最終行 = Range("C" & Rows.Count).End(xlUp).Row
    Range("A1:E" & 最終行).Copy Sheets("Sheet1").Range("A" & Rows.Count).End(xlUp).Offset(1)
 にしてみて下さい。

 単に
    Range("A1:E" & 最終行).Copy Range("A" & Rows.Count).End(xlUp).Offset(1)
 としたのでは、アクティブシートのA列の下から貼りついてしまうので
 Sheet("Sheet1")を付けて「Sheet1の！！」と意思表示して下さい。

 ちなみに、何度か書いていますが
 送られてきた情報が、今回転記する5列分以上あるのなら
 それらは　すべて残しておくのが良いと思います。

 最終的に一つのシートにまとめるのなら
 項目の場所を決めて、もらえない商品の該当の列は空き列になっても
 貰った情報は、いつでも使える様な形で保管しておくのが良いと思いますよ。
 せっかくデータをまとめるのでしたら。

 (HANA)
 　　

---

HANAさま
＞物品Aのシートの部署名の部分に　きっとスペースが入っているのだと思います。
→入っていました！スペース。部署名の後に22〜28個のスペースがありました。
とりあえず、置換を使用して消去してみました。(Sheet1集約の部分で。)

＞同じブック（マクロブック）に対応表を作成してもらうと良いと思います。
集計用のブックに対応表を作成しました。
=IF(COUNTIF($H$3:$H$75,C3),VLOOKUP(C3,$H$3:$I$75,2,FALSE),"不明")という感じで、
これを最大行になるであろう辺りまでコピーしておき、それを集約したSheet1に貼付して使用してみました。

＞送られてきた情報が、今回転記する5列分以上あるのならそれらは、すべて残しておくのが良いと思います。
→業者からの元データは、そのまま残してあります。
そして、今回必要とする5項目以外では今後必要となるデータはほとんどありません。
(同じ内容を違う言葉で何回も入力(出庫数、納入数、在庫数等)してある、商品の規格や薬品コード等、なので)
たぶん、今後必要となりそうなのは金額なので、その部分を他の5項目と一緒に残せるようします！上手くいくか不安ですが…。

＞アクティブシートの最終行までの範囲を、Sheet1の続きに貼りつけるなら…
→ここは、以下のような感じで良いのでしょうか？
Sub Sheet1コピー()

    Dim 最終行 As Long
    最終行 = Range("C" & Rows.Count).End(xlUp).Row
    Range("A1:F" & 最終行).Copy Sheets("Sheet1").Range("A" & Rows.Count).End(xlUp).Offset(1)
    Selection.SpecialCells(xlCellTypeVisible).Select
    Application.CutCopyMode = False
End Sub

現在、だいたい下記のような流れで実行する形にしてみました。
\x{fffd}@：業者からの元データを「移動とコピー」から、集計用ブックにコピーする(手作業)。
\x{fffd}A：データを必要な6項目に、それぞれ物品別で整理する。
Sub aデータ整理()
'Keyboard Shortcut: Ctrl+a

    Sheets("900708").Select
    Application.Run "'集計用　最終版.xlsm'!石鹸データ整理5L"
『各データ整理のマクロは、Sub サニサ250()
    Dim mxR As Long
    Columns("A:B").Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
    Range("A8").Value = Range("F6").Value  
    Range("B8").Value = Range("E4").Value  
    Rows("1:6").Delete Shift:=xlUp
    Range("C:C,E:N,P:Q").Delete Shift:=xlToLeft
    Range("A1").Value = "商品名"
    Range("B1").Value = "出庫月"
    Range("C1").Value = "部署"
    Range("D1").Value = "出庫数"
    Range("E1").Value = "金額"
    Range("F1").Value = "使用量"
    mxR = Range("C" & Rows.Count).End(xlUp).Row
    Range("F2:F" & mxR).FormulaR1C1 = "=250*RC[-2]"  
    Range("A2:A" & mxR).Value = Range("A2")         
    Range("B2:B" & mxR).Value = Range("B2")        
End Sub　こんな感じです。』
    Sheets("900709").Select
    Application.Run "'集計用　最終版.xlsm'!石鹸データ整理5L"
    Sheets("903488").Select
    Application.Run "'集計用　最終版.xlsm'!石鹸データ整理1L"
    Sheets("903722").Select
    Application.Run "'集計用　最終版.xlsm'!石鹸データ整理1L"
    Sheets("サニサーラ40").Select
    Application.Run "'集計用　最終版.xlsm'!サニサ40"
    Sheets("サニサーラ250").Select
    Application.Run "'集計用　最終版.xlsm'!サニサ250"
    Sheets("サニサーラ500").Select
    Application.Run "'集計用　最終版.xlsm'!サニサ500"
    Sheets("ベルコムローション").Select
    Application.Run "'集計用　最終版.xlsm'!ベルコムローション"
    Sheets("ウェルアップ").Select
    Application.Run "'集計用　最終版.xlsm'!ウェルアップ"
End Sub
\x{fffd}B：\x{fffd}Aで整理されたデータを、Sheet1に集約する。
Sub bシート1に集約()
' Keyboard Shortcut: Ctrl+b'
    Sheets("900708").Select
    Application.Run "'集計用　最終版.xlsm'!Sheet1コピー"
    Sheets("900709").Select
    Application.Run "'集計用　最終版.xlsm'!Sheet1コピー"
    Sheets("903488").Select
    Application.Run "'集計用　最終版.xlsm'!Sheet1コピー"
    Sheets("903722").Select
    Application.Run "'集計用　最終版.xlsm'!Sheet1コピー"
    Sheets("サニサーラ40").Select
    Application.Run "'集計用　最終版.xlsm'!Sheet1コピー"
    Sheets("サニサーラ250").Select
    Application.Run "'集計用　最終版.xlsm'!Sheet1コピー"
    Sheets("サニサーラ500").Select
    Application.Run "'集計用　最終版.xlsm'!Sheet1コピー"
    Sheets("ベルコムローション").Select
    Application.Run "'集計用　最終版.xlsm'!Sheet1コピー"
    Sheets("ウェルアップ").Select
    Application.Run "'集計用　最終版.xlsm'!Sheet1コピー"
    Sheets("Sheet1").Select
    Cells.Replace What:="900709-1 ウォシュボンピンク 5kg・23915 (個)", Replacement:="ﾋﾟﾝｸ" _
        , LookAt:=xlPart, SearchOrder:=xlByRows, MatchCase:=False, SearchFormat _
        :=False, ReplaceFormat:=False
    Cells.Replace What:="900708-1 ウォシュボンＧ 5kg・23947 (個)", Replacement:= _
        "ｳｫｯｼｭﾎﾞﾝＧ", LookAt:=xlPart, SearchOrder:=xlByRows, MatchCase:=False, _
        SearchFormat:=False, ReplaceFormat:=False
    Cells.Replace What:="903488-1 弱酸性ハンドソ−プ泡 1ﾘｯﾄﾙ", Replacement:="ﾊﾝﾄﾞｿｰﾌﾟ", _
        LookAt:=xlPart, SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:= _
        False, ReplaceFormat:=False
    Cells.Replace What:="903722-1 シャボネットユ・ムＰ−５（泡状） 1ﾘｯﾄﾙ", Replacement:= _
        "ｼｬﾎﾞﾈｯﾄ", LookAt:=xlPart, SearchOrder:=xlByRows, MatchCase:=False, _
        SearchFormat:=False, ReplaceFormat:=False
    Columns("C:C").Select
    Selection.Replace What:=" ", Replacement:="", LookAt:=xlPart, _
        SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
        ReplaceFormat:=False
    Selection.Replace What:="　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　", Replacement:="", _
        LookAt:=xlPart, SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:= _
        False, ReplaceFormat:=False
    Selection.Replace What:="　　　　　　　　　　　　　　　　　　　　　　　　　　　　　", Replacement:="", _
        LookAt:=xlPart, SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:= _
        False, ReplaceFormat:=False
    Selection.Replace What:="　　　　　　　　　　　　　　　　　　　　　　　　　　　　", Replacement:="", _
        LookAt:=xlPart, SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:= _
        False, ReplaceFormat:=False
    Selection.Replace What:="　　　　　　　　　　　　　　　　　　　　　　　　　　　", Replacement:="", _
        LookAt:=xlPart, SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:= _
        False, ReplaceFormat:=False
    Selection.Replace What:="　　　　　　　　　　　　　　　　　　　　　　　　　　", Replacement:="", _
        LookAt:=xlPart, SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:= _
        False, ReplaceFormat:=False
    Selection.Replace What:="　　　　　　　　　　　　　　　　　　　　　　　　　", Replacement:="", _
        LookAt:=xlPart, SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:= _
        False, ReplaceFormat:=False
    Selection.Replace What:="　　　　　　　　　　　　　　　　　　　　　　　　", Replacement:="", _
        LookAt:=xlPart, SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:= _
        False, ReplaceFormat:=False
    Selection.Replace What:="　　　　　　　　　　　　　　　　　　　　　　　", Replacement:="", LookAt _
        :=xlPart, SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
        ReplaceFormat:=False
    Selection.Replace What:="　　　　　　　　　　　　　　　　　　　　　　", Replacement:="", LookAt _
        :=xlPart, SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
        ReplaceFormat:=False
    Sheets("対応表").Select　　→ここが対応表をコピーしているところです。
    Columns("G:I").Copy　　　ここもきっと最終行を応用できるのでしょうが、
    Sheets("Sheet1").Select　どうすれば良いかわからずです。
    Columns("G:G").Select
    ActiveSheet.Paste
    Cells.Select　　→書式を揃えてます。大小･フォント･罫線様々で見にくいので。
    With Selection.Font
        .Name = "ＭＳ Ｐゴシック"
        .Size = 12
        .Strikethrough = False
        .Superscript = False
        .Subscript = False
        .OutlineFont = False
        .Shadow = False
        .Underline = xlUnderlineStyleNone
        .TintAndShade = 0
        .ThemeFont = xlThemeFontMinor
    End With
    With Selection.Font
        .Name = "ＭＳ Ｐゴシック"
        .Size = 12
        .Strikethrough = False
        .Superscript = False
        .Subscript = False
        .OutlineFont = False
        .Shadow = False
        .Underline = xlUnderlineStyleNone
        .TintAndShade = 0
        .ThemeFont = xlThemeFontMinor
    End With　　→きっと1行になるんだろうな…とは思うのですが、すみません。
    Selection.Borders(xlDiagonalDown).LineStyle = xlNone
    Selection.Borders(xlDiagonalUp).LineStyle = xlNone
    Selection.Borders(xlEdgeLeft).LineStyle = xlNone
    Selection.Borders(xlEdgeTop).LineStyle = xlNone
    Selection.Borders(xlEdgeBottom).LineStyle = xlNone
    Selection.Borders(xlEdgeRight).LineStyle = xlNone
    Selection.Borders(xlInsideVertical).LineStyle = xlNone
    Selection.Borders(xlInsideHorizontal).LineStyle = xlNone
End Sub
\x{fffd}C：対応表と部署名があっていたら、対応部署名をコピーして本来の部署の欄に値を張付け、渡す部署順に出力されるよう昇順を直す。
Sub c部署名対応と昇順並べ替え()
    Columns("G:G").Copy
    Columns("C:C").PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    Rows("1:1").Delete Shift:=xlUp
    Cells.Select
    ActiveWorkbook.Worksheets("Sheet1").Sort.SortFields.Clear
    ActiveWorkbook.Worksheets("Sheet1").Sort.SortFields.Add Key:=Range("C2:C300") _
        , SortOn:=xlSortOnValues, Order:=xlAscending, CustomOrder:= _
        "Ａ５,ＮＩＣＵ,Ａ６,Ａ７,Ａ８,Ｂ３,ＩＣＵ,Ｂ４,Ｂ５,Ｂ６,Ｃ２,Ｃ３,Ｃ４,Ｃ５,Ｅ４,西５,ＨＤ,ＥＲ,手術室,外来", DataOption _
        :=xlSortNormal
    With ActiveWorkbook.Worksheets("Sheet1").Sort
        .SetRange Range("A1:H300")
        .Header = xlYes
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
    Range("I1").Select
End Sub
\x{fffd}D：Sheet1のデータを部署別に出力する。
Sub d部署別出力()
    Dim i As Long, shi As Long, MyR As Long
    Dim tbl As Variant
    Dim ws As Worksheet
    For shi = 1 To 1
        With Sheets(shi)
            tbl = .Range("A1", .Range("F" & Rows.Count).End(xlUp)).Value
        End With
        For i = 3 To UBound(tbl, 1)
            On Error Resume Next
                Set ws = Worksheets(tbl(i, 3))
            On Error GoTo 0
            If ws Is Nothing Then
                Sheets.Add(after:=Sheets(Sheets.Count)).Name = tbl(i, 3)
                Sheets(tbl(i, 3)).Range("A1:F1").Value = Array("商品名", "出庫月", "部署", "出庫数", "金額", "使用量")
            Else
                Set ws = Nothing
            End If
            With Sheets(tbl(i, 3))
                MyR = .Range("A" & Rows.Count).End(xlUp).Row + 1
                .Range("A" & MyR).Value = tbl(i, 1)
                .Range("B" & MyR).Value = tbl(i, 2)
                .Range("C" & MyR).Value = tbl(i, 3)
                .Range("D" & MyR).Value = tbl(i, 4)
                .Range("E" & MyR).Value = tbl(i, 5)
                .Range("F" & MyR).Value = tbl(i, 6)
            End With
        Next
    Next
End Sub
以上です〜。
長文ですみません。（Machi）

---

 ＞→入っていました！スペース。部署名の後に22〜28個のスペースがありました。 
 ＞とりあえず、置換を使用して消去してみました。(Sheet1集約の部分で。) 
 (bシート1に集約)マクロの　Columns("C:C").Select〜　の部分でしょうか？
 何回かに分けて置換されている様に感じますが、何かわけがありますか？

 ＞=IF(COUNTIF($H$3:$H$75,C3),VLOOKUP(C3,$H$3:$I$75,2,FALSE),"不明")という感じで、 
 ＞これを最大行になるであろう辺りまでコピーしておき、それを集約したSheet1に貼付して使用してみました。 
 ・・・うまく行きますか？
 Sheet1と、マクロがあるブックが同じだとしても、シートは別ですよね？
 すると$H$3:$I$75部分は、シート間参照になると思いますが・・・。

 あ、この表も含めて　sheet1にコピーしてるんですね。
 まずは、シート間参照の式を作ってください。

 対応表が別シートにある場合の作り方がこちらに載っていますので。
https://www.excel.studio-kazu.jp/func/vlookup.html#a_sheet

 ＞＞送られてきた情報が、今回転記する5列分以上あるのならそれらは、すべて残しておくのが良いと思います。 
 ＞→業者からの元データは、そのまま残してあります。
 これは、送られてきたままの状態で残してあると言う事ですよね？
 どちらにしても、当然これは残しておくのが良いとは思いますが
 今作っているリストは「今後使いやすい形にしておく」のが良いと思いますよ。
 ５列分以外のデータを、今後使うか、使わないかは別として。
 データがあるとなると、今は必要ないと思っていも、今後確認したい事が出てくると思います。

 ５列分のデータを残しておく作業と一緒にその他のデータも作業をしておけば
 「あ〜〜」ってなった時に再び作業をするよりも　時間が短縮出来ると思います。
 現在行方向のデータ量が問題になっているだけで、列方向のデータ量が増えても、問題になりませんよね。

 たとえば、何ml入りだったのか。もともとどういう項目名で来ていたのか。
 もともとどういう部署名だったのか。
 そういうのは、残しておいた方が良いです。

 その他、まったく同じ値が入っているなら省いてしまってもよいかもしれませんが
 「たまたま今の所同じ値が入っている」というだけなら、それもやはり
 リストとして、残るようにしておいた方が良いです。

 近い将来金額が必要になりそうなんですよね？
 遠い将来はどうでしょう？
 未来はわからないので、今の段階で将来の道を狭めてしまうのは
 得策ではないと思います。 

 ＞商品の規格や薬品コード等
 これらが、何列分くらいあるかわからないですが。。。
 これらも残す事で、現在の作業効率が著しく落ちるなら
 同時に作業する事は　見合わせた方が良いのかもしれませんが。

 ＞＞アクティブシートの最終行までの範囲を、Sheet1の続きに貼りつけるなら… 
 ＞→ここは、以下のような感じで良いのでしょうか？ 
 えっと、
    Selection.SpecialCells(xlCellTypeVisible).Select
 の部分は何をさせようと思ってますか？

 ただ、書式を整える必要があるのなら　最初から値だけ転記するのがよさそうですね。

 それと、コピーなんかも　(aデータ整理)マクロでデータを整理したらただちに
 sheet1に貼り付け作業もやってしまえば良いと思います。

    Sheets("900708").Select
    Application.Run "'集計用　最終版.xlsm'!石鹸データ整理5L"
    Application.Run "'集計用　最終版.xlsm'!Sheet1コピー"

    Sheets("900709").Select
    ・・・・・・

 ってな感じで。

 途中でマクロが止まってしまった場合の事は少し考えないといけなくなりますが。

 なお、データ整理のマクロの
    Range("A1").Value = "商品名"
    Range("B1").Value = "出庫月"
    Range("C1").Value = "部署"
    Range("D1").Value = "出庫数"
    Range("E1").Value = "金額"
    Range("F1").Value = "使用量"
 部分は
 ＞Range("A1:F1").Value = Array("商品名", "出庫月", "部署", "出庫数", "金額", "使用量")
 この部分と一緒です。
 　（６行に分かれていた方が、わかりやすいかもしれませんが？）

 まだいろいろありますが、まずはこのあたりでどうでしょう？

 (HANA)

---

HANAさま

＞ 何回かに分けて置換されている様に感じますが、何かわけがありますか？
スペースの量が文字数によって違っていたため、28個のスペースをスペース0個に置換、27個の…26個の…という感じに、1個1個やっていったためです。
置換の方法はそれ以外知らないもので、すみません。
「この列のスペースは全部削除して」というようなやり方もできるのでしょうか？

＞まずは、シート間参照の式を作ってください。
→もう、本当にすみません。
この対応表コピーすればいいのかな？などと考えていました。
対応表のシート名は「対応表」なので、
=IF(COUNTIF(対応表!$H$3:$H$75,C3),VLOOKUP(C3,対応表!$H$3:$I$75,2,FALSE),"不明")を、Sheet1のG列に入れたのですが、良いでしょうか？

＞たとえば、何ml入りだったのか。もともとどういう項目名で来ていたのか…
→商品名に、薬品コード、商品名、規格、納入コード、梱包単位がすべて入っています。
900709-1 ウォシュボンピンク 5kg・23915 (個)←こんな感じです。
長くて見にくいかな、と思いリネームしてしまいましたが、
指摘していただいた内容を考えると、商品名をそのまま残すほうが安全かな、と考えなおしました。

＞その他、まったく同じ値が入っているなら省いてしまってもよいかもしれませんが…
この部分は、業者さんに問い合わせたところ、
他にも色々な施設に納品しているため、その施設用に言葉が違っているだけで、
内容はすべて同じとのことでしたので、ここは大丈夫そうです。

＞えっと、

    Selection.SpecialCells(xlCellTypeVisible).Select
 の部分は何をさせようと思ってますか？
→多分、使用量を出すために入っている数式があるので、値のみをコピーしようとしたんだと思うのですが、
実際にSheet１に書き出されたデータは、数式ごとコピーされているので、どこかで失敗しているのですね(>_<)。もう一度やりなおしてみます。

＞それと、コピーなんかも　(aデータ整理)マクロでデータを整理したらただちに

 sheet1に貼り付け作業もやってしまえば良いと思います。
途中でマクロが止まってしまった場合の事は少し考えないといけなくなりますが。
→最終的に、１つになるとすっごく嬉しいです。
ただ、2012年の12か月分のデータの中に、何度か書式が違う
(データが入力されているセルが違う、物品のシート名が違う等。
他の施設にも提出しているためか、時々混ざっちゃうんだそうです。）ものがあったため、その対処が不安です。（Machi)

---

 ＞「この列のスペースは全部削除して」というようなやり方もできるのでしょうか？ 
 置換前の文字に　スペースを一つ。
 置換後の文字に何も入力せずに、すべて置換してみて下さい。

 ＞=IF(COUNTIF(対応表!$H$3:$H$75,C3),VLOOKUP(C3,対応表!$H$3:$I$75,2,FALSE),"不明")を、
 ＞Sheet1のG列に入れたのですが、良いでしょうか？ 
 そうですね。

 後はこの式をVBAが入力してくれるようにすると良いと思います。
 当初の私が思い違いをしていた頃に、記録マクロで数式を入力しましたよね。

 そんな感じで　「C3:C10を選択して　数式を入力して Ctrl+Enter で確定」を
 記録にとってみて下さい。

 実行すると、C3:10に数式が入るコードが完成しますので
 10行目までではなく、データのある最終行迄入力される様にすれば良いですね。

 ＞→商品名に、薬品コード、商品名、規格、納入コード、梱包単位がすべて入っています。 
 でしたら、この列はそのまま残しておいて　必要な所だけ抜き出す　とか
 ここもVLOOKUP関数でわかりやすい表示を参照するとか　してはどうですか？

 ＞実際にSheet１に書き出されたデータは、数式ごとコピーされているので、どこかで失敗しているのですね(>_<)。
 いや、もともと数式ごとコピーする様なコードになってます。

 後から書式の設定などをしている様なので
 元からデータだけを参照できる様にしておくのがよさそうですね。

 たとえば
    Range("A8").Value = Range("F6").Value 
 で、F6セルの値がA8セルに入力された様に　↓きっと細かい修正が必要になってくると思いますが
    Sheets("Sheet1").Range("A" & Rows.Count).End(xlUp).Offset(1).Resize(最終行, 6).Value = Range("A1:F" & 最終行).Value
 最終行が「10」だった場合
 Sheet1のA列の続きの10行6列の範囲にA1:F10の範囲の値が入力されます。

 ＞ただ、2012年の12か月分のデータの中に、何度か書式が違う
 ＞ものがあったため、その対処が不安です
 そうですね。

 作業前に、想定している場所に　想定しているものがあるかどうか
 確認しておいた方がよさそうですね。

 商品シートは9枚ある様ですが、様式は全部違うのですか？

 (HANA)

---

HANAさま
返信が遅くなり申し訳ありません。

＞置換前の文字に　スペースを一つ。
＞置換後の文字に何も入力せずに、すべて置換してみて下さい。
Selection.Replace What:=" ", Replacement:="", LookAt:=xlPart, _
SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
ReplaceFormat:=False
半角スペースの部分と全角スペースの部分があったために、
上記のだけでは、全部消えなかったようでした。
なので、Cells.Replace What:=" ", Replacement:="", LookAt:=xlPart, SearchOrder:= _
xlByRows, MatchCase:=False, SearchFormat:=False, ReplaceFormat:=False
もう１つ、↑を入れたところ、すべてのスペースが削除されました。

 ＞=IF(COUNTIF(対応表!$H$3:$H$75,C3),VLOOKUP(C3,対応表!$H$3:$I$75,2,FALSE),"不明")を、
 ＞後はこの式をVBAが入力してくれるようにすると良いと思います。
 ＞当初の私が思い違いをしていた頃に、記録マクロで数式を入力しましたよね。
これは、↓みたいな感じで良いでしょうか？
Sub c部署名対応()
    Dim mxR As Long
    Range("G2").Select
    ActiveCell.FormulaR1C1 = "対応名"
    mxR = Range("C" & Rows.Count).End(xlUp).Row
    Range("G3:G" & mxR).Select
    Selection.FormulaR1C1 = _
        "=IF(COUNTIF(対応表!R3C8:R75C8,RC[-4]),VLOOKUP(RC[-4],対応表!R3C8:R75C9,2,FALSE),""不明"")"
End Sub

 ＞＞→商品名に、薬品コード、商品名、規格、納入コード、梱包単位がすべて入っています。 
 ＞でしたら、この列はそのまま残しておいて　必要な所だけ抜き出す　とか
 ＞ここもVLOOKUP関数でわかりやすい表示を参照するとか　してはどうですか？
そうですね、やってみます！

 ＞いや、もともと数式ごとコピーする様なコードになってます。
うわぁ…。すみません。マクロの記録の時に、
可視セルのみコピーってしたと思っていたのですが、やっていなかったんですね、わたし。

＞たとえば

    Range("A8").Value = Range("F6").Value 
 で、F6セルの値がA8セルに入力された様に　↓きっと細かい修正が必要になってくると思いますが
    Sheets("Sheet1").Range("A" & Rows.Count).End(xlUp).Offset(1).Resize(最終行, 6).Value = Range("A1:F" & 最終行).Value
 最終行が「10」だった場合
 Sheet1のA列の続きの10行6列の範囲にA1:F10の範囲の値が入力されます。
Sub Sheet1コピー()
    Dim 最終行 As Long
    最終行 = Range("C" & Rows.Count).End(xlUp).Row    
    Range("A1:F" & 最終行).Copy Sheets("Sheet1").Range("A" & Rows.Count).End(xlUp).Offset(1)
End Sub　これを、
Sub Sheet1コピー()
    Dim 最終行 As Long
    最終行 = Range("C" & Rows.Count).End(xlUp).Row　（→この部分が必要かわからなかったのですが取敢えずそのまま残しました。）
    Sheets("Sheet1").Range("A" & Rows.Count).End(xlUp).Offset(1).Resize(最終行, 6).Value = Range("A1:F" & 最終行).Value
End Sub　これに変更すれば良いのでしょうか？
実行すると、Sheet1にコピーされた時点で、書式が全部揃っています！
Resizeという部分で、↑ができるようになるのでしょうか？感動です〜。

＞商品シートは9枚ある様ですが、様式は全部違うのですか？
様式は3種類ですが、そのうち1種類はデータの項目名や書式が違うだけなので、
実質は、2種類となります。
(Machi)

---

 ＞半角スペースの部分と全角スペースの部分があったために、 〜〜
 ＞〜〜　すべてのスペースが削除されました。
 そうですね。
 そうしてもらえると良いと思います。

 ＞これは、↓みたいな感じで良いでしょうか？
 ＞Sub c部署名対応()
 それでうまくいってるなら、良いと思います。
 もう一歩進んでみますと。。。
 とりあえずSelectをなくしましょう。

 '------
    Dim mxR As Long
    Range("G2").Value = "対応名"
    mxR = Range("C" & Rows.Count).End(xlUp).Row
    Range("G3:G" & mxR).FormulaR1C1 = _
        "=IF(COUNTIF(対応表!R3C8:R75C8,RC[-4]),VLOOKUP(RC[-4],対応表!R3C8:R75C9,2,FALSE),""不明"")"
 '------

 ＞マクロの記録の時に、
 ＞可視セルのみコピーってしたと思っていたのですが、やっていなかったんですね、わたし。
 いえ、その後私が書き換えた時に、値化に対応してなかったのです。
 すみません。

 ＞Resizeという部分で、↑ができるようになるのでしょうか？感動です〜。
 残念ながら　違います。。。

 たとえば
 　Range("A1").Copy Range("B1")
 これは、A1セルをコピーして　B1セルに貼りつけなさい。と言う指令です。
 すると、A1セルに設定している書式なども一緒に貼りつきます。
 数式が入っていたら、数式の状態で貼りつきます。
 　　通常のコピペって　そーゆーもの　ですよね？

 そして
 　Range("B1").Value = Range("A1").Value
 これは、A1セルの内容をB1セルにいれなさい。と言う指令です。
 書式は引き継がれませんし、数式が入っていたらその結果が転記されます。
 　　Machiさんが、A1セルの表示を見て B1セルに入力しなおす　イメージです。

 Resizeと言うのは、ワークシート関数で
 OFFSET(基準, 行数, 列数, [高さ], [幅])ってのがあると思いますが
 [高さ][幅]で指定するのと同じ様なイメージです。

 たとえば、OFFSET(A1,,,10,6) と書いてあったら　A1セルを基準に10行×6列の範囲　を表します。
 OFFSET(A1,1,,10,6)だと、A1セルから一つ下がって10行×6列の範囲・・・A2:F11・・・の事です。

 VBAの方に帰って、コードに似せた例にすると
 Sheets("Sheet1").Range("A1").Offset(1).Resize(10, 6)
 Sheet1のA1セルから一つ下がって10行×6列の範囲

 です。

 Sheets("Sheet1").Range("A" & Rows.Count).End(xlUp).Offset(1).Resize(最終行, 6).Value = Range("A1:F" & 最終行).Value
 この部分は
 Sheet1のA列の入力がある最後のセルの一つ下から　変数：最終行　に入っている行数×6列の範囲に
 現在アクティブになっているシートの、"A1:F" & 最終行 の範囲の値を入れなさい。

 と、書いてある事になります。

 ×書式がそろっている
 ○コピー元の書式を引き継いでいない

 と言う事なんですが、納得出来そうですか？

 (HANA) 

---

HANAさま

＞×書式がそろっている
＞○コピー元の書式を引き継いでいない
＞と言う事なんですが、納得出来そうですか？
はい、説明頂いた内容はわかりました。
何が関数で何がVBAなのか、区別もつきませんで、すみませんm(_　_)m。
（Machi)

---

HANAさま

部署名などを対応表に沿って変換してから、出力する部署名順に並べかえるようにしました。
Sub c部署名対応と昇順並べ替え()

    Dim mxR As Long
    Range("G2").Select
    ActiveCell.FormulaR1C1 = "対応名"
    mxR = Range("C" & Rows.Count).End(xlUp).Row
    Range("G3:G" & mxR).Select
    Selection.FormulaR1C1 = _
        "=IF(COUNTIF(対応表!R3C8:R75C8,RC[-4]),VLOOKUP(RC[-4],対応表!R3C8:R75C9,2,FALSE),""不明"")"
    Rows("1:1").Delete Shift:=xlUp
    Cells.Select
    ActiveWorkbook.Worksheets("Sheet1").Sort.SortFields.Clear
    ActiveWorkbook.Worksheets("Sheet1").Sort.SortFields.Add Key:=Range("G2:G300") _
        , SortOn:=xlSortOnValues, Order:=xlAscending, CustomOrder:= _
        "Ａ５,ＮＩＣＵ,Ａ６,Ａ７,Ａ８,Ｂ３,ＩＣＵ,Ｂ４,Ｂ５,Ｂ６,Ｃ２,Ｃ３,Ｃ４,Ｃ５,Ｅ４,西５,ＨＤ,ＥＲ,手術室,外来", DataOption _
        :=xlSortNormal
    With ActiveWorkbook.Worksheets("Sheet1").Sort
        .SetRange Range("A1:H300")
        .Header = xlYes
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
End Sub
このあと、対応名でシートを出力したかったので、
HANAさまに頂いたマクロを、以下のように変えてみたのですが、
そうしたら、最初の部署になるＡ５だけシートが出力されなくなってしまいました。
Sub d部署別出力()
    Dim i As Long, shi As Long, MyR As Long
    Dim tbl As Variant
    Dim ws As Worksheet

    For shi = 1 To 1
        With Sheets(shi)
            tbl = .Range("A1", .Range("G" & Rows.Count).End(xlUp)).Value
        End With
        For i = 7 To UBound(tbl, 1)
            On Error Resume Next
                Set ws = Worksheets(tbl(i, 7))
            On Error GoTo 0
            If ws Is Nothing Then
                Sheets.Add(after:=Sheets(Sheets.Count)).Name = tbl(i, 7)
                Sheets(tbl(i, 7)).Range("A1:G1").Value = Array("商品名", "出庫月", "部署", "出庫数", "金額", "使用量", "対応名")
                Range("A1:G1").Select
                Selection.AutoFilter
                Range("H1").Select
                ActiveCell.FormulaR1C1 = "=SUBTOTAL(9,C[-2])"
            Else
                Set ws = Nothing
            End If
            With Sheets(tbl(i, 7))
                MyR = .Range("A" & Rows.Count).End(xlUp).Row + 1
                .Range("A" & MyR).Value = tbl(i, 1)
                .Range("B" & MyR).Value = tbl(i, 2)
                .Range("C" & MyR).Value = tbl(i, 3)
                .Range("D" & MyR).Value = tbl(i, 4)
                .Range("E" & MyR).Value = tbl(i, 5)
                .Range("F" & MyR).Value = tbl(i, 6)
                .Range("G" & MyR).Value = tbl(i, 7)
            End With

        Next
    Next

End Sub
やりかたを間違えているのでしょうが、どこを直せば良いのかわかりません。
よろしくお願いいたします。(Machi)

---

HANAさま
作成したマクロを全部つなげてみました。
どのようにつなげるべきなのか、わからなかったので
とりあえず、行をあけて貼り付けてあります。
対応名の部分は、応急処置として
対応名項目列をC列に移動させることで、全部出力されるようになりました。
物品名のVLOOKUPは、これから入れる予定です。

Sub ★一括整理()

    Sheets("900708").Select
    Application.Run "'集計用　最終版.xlsm'!石鹸データ整理5L"
    Application.Run "'集計用　最終版.xlsm'!Sheet1コピー"

    Sheets("900709").Select
    Application.Run "'集計用　最終版.xlsm'!石鹸データ整理5L"
    Application.Run "'集計用　最終版.xlsm'!Sheet1コピー"

    Sheets("903488").Select
    Application.Run "'集計用　最終版.xlsm'!石鹸データ整理1L"
    Application.Run "'集計用　最終版.xlsm'!Sheet1コピー"

    Sheets("903722").Select
    Application.Run "'集計用　最終版.xlsm'!石鹸データ整理1L"
    Application.Run "'集計用　最終版.xlsm'!Sheet1コピー"

    Sheets("サニサーラ40").Select
    Application.Run "'集計用　最終版.xlsm'!サニサ40"
    Application.Run "'集計用　最終版.xlsm'!Sheet1コピー"

    Sheets("サニサーラ250").Select
    Application.Run "'集計用　最終版.xlsm'!サニサ250"
    Application.Run "'集計用　最終版.xlsm'!Sheet1コピー"

    Sheets("サニサーラ500").Select
    Application.Run "'集計用　最終版.xlsm'!サニサ500"
    Application.Run "'集計用　最終版.xlsm'!Sheet1コピー"

    Sheets("ベルコムローション").Select
    Application.Run "'集計用　最終版.xlsm'!ベルコムローション"
    Application.Run "'集計用　最終版.xlsm'!Sheet1コピー"

    Sheets("ウェルアップ1Ｌ").Select
    Application.Run "'集計用　最終版.xlsm'!ウェルアップ"
    Application.Run "'集計用　最終版.xlsm'!Sheet1コピー"

    Sheets("Sheet1").Select
    Cells.Replace What:="900709-1 ウォシュボンピンク 5kg・23915 (個)", Replacement:="ピンク900709-1 ウォシュボンピンク 5kg・23915 (個)" _
        , LookAt:=xlPart, SearchOrder:=xlByRows, MatchCase:=False, SearchFormat _
        :=False, ReplaceFormat:=False
    Cells.Replace What:="900708-1 ウォシュボンＧ 5kg・23947 (個)", Replacement:= _
        "ｳｫｯｼｭﾎﾞﾝＧ900708-1 ウォシュボンＧ 5kg・23947 (個)", LookAt:=xlPart, SearchOrder:=xlByRows, MatchCase:=False, _
        SearchFormat:=False, ReplaceFormat:=False
    Cells.Replace What:="903488-1 弱酸性ハンドソ−プ泡 1ﾘｯﾄﾙ", Replacement:="ﾊﾝﾄﾞｿｰﾌﾟ903488-1 弱酸性ハンドソ−プ泡 1ﾘｯﾄﾙ", _
        LookAt:=xlPart, SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:= _
        False, ReplaceFormat:=False
    Cells.Replace What:="903722-1 シャボネットユ・ムＰ−５（泡状） 1ﾘｯﾄﾙ", Replacement:= _
        "ｼｬﾎﾞﾈｯﾄ903722-1 シャボネットユ・ムＰ−５（泡状） 1ﾘｯﾄﾙ", LookAt:=xlPart, SearchOrder:=xlByRows, MatchCase:=False, _
        SearchFormat:=False, ReplaceFormat:=False
    Cells.Replace What:="　", Replacement:="", LookAt:=xlPart, SearchOrder:= _
        xlByRows, MatchCase:=False, SearchFormat:=False, ReplaceFormat:=False
    Cells.Replace What:=" ", Replacement:="", LookAt:=xlPart, SearchOrder:= _
        xlByRows, MatchCase:=False, SearchFormat:=False, ReplaceFormat:=False

   Dim mxR As Long
    Range("G2").Select
    ActiveCell.FormulaR1C1 = "対応名"
    mxR = Range("C" & Rows.Count).End(xlUp).Row
    Range("G3:G" & mxR).Select
    Selection.FormulaR1C1 = _
        "=IF(COUNTIF(対応表!R3C8:R75C8,RC[-4]),VLOOKUP(RC[-4],対応表!R3C8:R75C9,2,FALSE),""不明"")"
    Rows("1:1").Delete Shift:=xlUp
    Cells.Select
    ActiveWorkbook.Worksheets("Sheet1").Sort.SortFields.Clear
    ActiveWorkbook.Worksheets("Sheet1").Sort.SortFields.Add Key:=Range("G2:G300") _
        , SortOn:=xlSortOnValues, Order:=xlAscending, CustomOrder:= _
        "Ａ５,ＮＩＣＵ,Ａ６,Ａ７,Ａ８,Ｂ３,ＩＣＵ,Ｂ４,Ｂ５,Ｂ６,Ｃ２,Ｃ３,Ｃ４,Ｃ５,Ｅ４,西５,ＨＤ,ＥＲ,手術室,外来", DataOption _
        :=xlSortNormal
    With ActiveWorkbook.Worksheets("Sheet1").Sort
        .SetRange Range("A1:H300")
        .Header = xlYes
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With

    Columns("G:G").Select
    Selection.Cut
    Columns("C:C").Select
    Selection.Insert Shift:=xlToRight

    Dim i As Long, shi As Long, MyR As Long
    Dim tbl As Variant
    Dim ws As Worksheet

    For shi = 1 To 1
        With Sheets(shi)
            tbl = .Range("A1", .Range("G" & Rows.Count).End(xlUp)).Value
        End With
        For i = 2 To UBound(tbl, 1)
            On Error Resume Next
                Set ws = Worksheets(tbl(i, 3))
            On Error GoTo 0
            If ws Is Nothing Then
                Sheets.Add(after:=Sheets(Sheets.Count)).Name = tbl(i, 3)
                Sheets(tbl(i, 3)).Range("A1:G1").Value = Array("商品名", "出庫月", "対応名", "部署", "出庫数", "金額", "使用量")
                Range("A1:G1").Select
                Selection.AutoFilter
                Range("H1").Select
                ActiveCell.FormulaR1C1 = "=SUBTOTAL(9,C[-1])"
            Else
                Set ws = Nothing
            End If
            With Sheets(tbl(i, 3))
                MyR = .Range("A" & Rows.Count).End(xlUp).Row + 1
                .Range("A" & MyR).Value = tbl(i, 1)
                .Range("B" & MyR).Value = tbl(i, 2)
                .Range("C" & MyR).Value = tbl(i, 3)
                .Range("D" & MyR).Value = tbl(i, 4)
                .Range("E" & MyR).Value = tbl(i, 5)
                .Range("F" & MyR).Value = tbl(i, 6)
                .Range("G" & MyR).Value = tbl(i, 7)
            End With
        Next
    Next
End Sub
つなげ方がわかりませんが、こんな感じで良いのでしょうか？
(Machi)

---

 ＞そうしたら、最初の部署になるＡ５だけシートが出力されなくなってしまいました。
 なんでしょうねぇ。。。
 ＞対応名項目列をC列に移動させることで、全部出力されるようになりました。
 のコードと見比べると、列の位置だけが違うなら
 ＞For i = 7 To UBound(tbl, 1)
 ＞For i = 2 To UBound(tbl, 1)
 この部分が違っているのは、おかしいです。 

 この i は「行数」として使ってます。
 なので、データが2行目から始まっているなら　2　のままで良いのですが。

 ＞つなげ方がわかりませんが、こんな感じで良いのでしょうか？

 下にコピペして、続けて実行される様にしても良いと思いますが
 商品毎のデータを整理する所で
    Application.Run "'集計用　最終版.xlsm'!石鹸データ整理5L"
 ってやってますよね？

 そんな感じでやっておくのが、すっきりすると思います。

 単独で実行したいこともあるかもしれませんので。

 ちなみに、シートを一つにしてからの作業になりますので
    For shi = 1 To 1 ・・・と、それに対応する・・・Next
 をなくして
        With Sheets(shi)
 部分で、直接シート名を指定
        With Sheets("Sheet1")
 で良いと思います。

 ＞何が関数で何がVBAなのか、区別もつきませんで
 私が気軽に「関数」と言っているから、わかりにくいと思います。すみません。
 今、私が「関数」で表したい事は　シートのセルに数式を埋め込む　と言う事です。

 VBAにはVBAの関数が有ったり、VBAでもワークシート関数が使えたりするのですが
 「Machiさんが、セルに数式を入れるのと同じ様に
 　VBAに、セルに数式を入れてもらいましょう。
 　VBAより、数式の方が敷居が低くて考えやすいだろうから。」
 って思ってます。

 少し脱線しますが
 '------
    Sub VBAで足し算()
        Range("C1").Value = Range("A1").Value + Range("B1").Value
    End Sub
 '------
    Sub 数式で足し算()
        Range("C2").FormulaR1C1 = "=SUM(RC[-2]:RC[-1])"
    End Sub
 '------
 VBAで足し算　を実行すると、A1+B1の結果がC1セルに入力されます。
 このコードを書くためには
 　それぞれのセルを表したい時、どの様に書くのか。
 　足し算をさせたい時、どの様に書くのか。
 知っておかないといけません。

 数式で足し算　を実行すると、C2セルに =SUM(A2:B2) の式が入力されるので、
 C2セルに A2+B2 の 結果が表示される事になります。

 このコードは、マクロの記録で
 　１．C2セルを選択
 　２．=SUM(A2:B3) の式を入力
 をコード化して、不要部分を削除すると完成します。
    Range("C2").Select
    ActiveCell.FormulaR1C1 = "=SUM(RC[-2]:RC[-1])"
    Range("C3").Select
 2行目の「ActiveCell」が、その上の「Range("C2")」の事なので、置き換えられる。
 3行目の C3セルを選択する動作は必要ないので、消してOK
 　　。。。。って事を知っておかないと完成はしませんが。。。

 『足し算』という簡単な例なので　いまいちピンとこないかもしれませんが
 VLOOKUP関数をセルに埋める
    Selection.FormulaR1C1 = _
        "=IF(COUNTIF(対応表!R3C8:R75C8,RC[-4]),VLOOKUP(RC[-4],対応表!R3C8:R75C9,2,FALSE),""不明"")"
 と、同じ結果が得られる様なコードを書く
 事を考えてみてもらうと、多くの事を知らなくても結果が得られていると
 実感してもらえるのではないかと思いますが、どうでしょう？

 あ・・・もしかして　Resizeの説明の所で ワークシート関数のOFFSET関数を持ち出したのが
 混乱させちゃいましたか？

 ちなみに、d部署別出力のコードは　元データが一つにまとまったり
 部署別出力するまでに並べ替えが行われたりしているので
 上で書いた所以外も、もう少し変更できる所があります。

 そのあたりも修正していけたら良いと思います。

 が、まずは　商品毎シートでデータをまとめる所がもう少し何とかしたい感じです。

 ＞＞商品シートは9枚ある様ですが、様式は全部違うのですか？ 
 ＞様式は3種類ですが、そのうち1種類はデータの項目名や書式が違うだけなので、 
 ＞実質は、2種類となります。 
 ここの所を、もっと詳しく教えてもらえませんか？

 出来るだけ同じコードで済む様にしておくのが良いと思います。
 完成しているコードで、同じ所と違う所を見極めて教えて下さい。

 (HANA)

---

HANAさま

＞For i = 7 To UBound(tbl, 1)
＞For i = 2 To UBound(tbl, 1)
＞この部分が違っているのは、おかしいです。
＞この i は「行数」として使ってます。

行数だったのですね(>_<)。
HANAさまに頂いたときは、For i = 3 To UBound(tbl, 1)だったんです。
そして、tbl(i,3)の部分をシート名として書き出していたので、
今度はtbl(i, 7)のとこを書き出すのだから、全部7にすればいいのかなと考えて、
それまで3という数字が入っていた部分を、訳も分からず全部7に変えちゃったのです。
だから、7行目のデータからしか読み込まなかったんですね…。
応急処置で変更しているときに、3だと1行データが足りなくなることに気づき、
ステップインで動作を見ていて、2に変えたような気がします。すみません！

＞＞様式は3種類ですが、そのうち1種類はデータの項目名や書式が違うだけなので、 実質は、2種類となります。
＞ここの所を、もっと詳しく教えてもらえませんか？

様式１と様式２は、データの項目名と書式がちがっていますが、
ありがたいことに、必要な項目データの入っている列が同じです。
なので、コードは同じものを使用(使用量をかけるところを除いて)できます。
（Application.Run "'集計用　最終版.xlsm'!石鹸データ整理5L"と、
Application.Run "'集計用　最終版.xlsm'!石鹸データ整理１L"がそれにあたります。）
残りの様式３は、項目名が変わることがありますが、配置される列や行は変更ないことが多い(時々、行がずれて違う場所にありますが)です。
ただ、たびたびワークシートのシート名が変わっているため、それによるエラーが出ます。
(実行する前にしっかり確認すればいいのでしょうが、同じシート名でも数字や英字が半角だったり全角だったりするため、見た目で判別し辛いことが残念です）
こちらは、Application.Run "'集計用　最終版.xlsm'!サニサ40"とかです。
違う部分は容量の数値部分のみです。
ｻﾆｻ40が40ml、ｻﾆｻ250が250ml、ｻﾆｻ500が500ml、ﾍﾞﾙｺﾑﾛｰｼｮﾝも500ml、ｳｪﾙｱｯﾌﾟﾛｰｼｮﾝは1000mlと500mlです。ｳｪﾙｱｯﾌﾟﾛｰｼｮﾝの500mlは月によってシートがあったりなかったりなので、
今はマクロに入れていない状態です。
(Machi)

---

 ＞HANAさまに頂いたときは、For i = 3 To UBound(tbl, 1)だったんです。
 はい、上の方の段階では
 　１行目に合計があって
 　２行目に見出しがあって
 　３行目からデータ
 になっていた様でしたので、iは「3」から始めました。

 ＞3だと1行データが足りなくなることに気づき、 
 ＞ステップインで動作を見ていて、2に変えたような気がします。すみません！
 いいえ、この様にして　作ってあるコードと実際の動きを確認しながら
 希望の動きに変更して行って下さい。

 iが7行目から始まっていると、ステップインで実行していくと
 一回目のループで tbl(i, 7) にポインタを近づけた時
 想定した「Ａ５」ではなく、「ＮＩＣＵ」とかが表示されて
 ・・・？？？・・・
 ってのがわかったと思います。

 最初の内は、ステップインで実行中もどこの何を見れば良いのか
 分からないと思いますが「何がわかれば良いのか」を考えながら
 トライしてもらうと、そのうちわかってくると思います。

 ＞様式１と様式２は、データの項目名と書式がちがっていますが、

 今、置換の所で
 「900709-1 ウォシュボンピンク 5kg・23915 (個)」
 こんなのを検索してますね。

 このセルに入力されてくる文字は、毎回同じでしょうか？
 同じであれば、これをキーにして　数量や置換後に表示したい文字を
 VLOOUP関数で参照させることにすると
 容量部分も共通化が出来ると思いますが、どうなんでしょう？

 また
 ＞配置される列や行は変更ないことが多い(時々、行がずれて違う場所にありますが)
 これは、ずれにもパターンがあると思いますが、どの項目がどの位置にずれる事があるのでしょう？

 「行がずれる」って事は、項目名などが入力されている部分に関してですよね？
 ずれている場合は、データの開始行も一緒にずれるのでしょうか？
 でしたら逆に、データの見出しがどの行にあるかがわかれば　ずれているかどうか判断できるのでしょうか？

 (HANA)

---

HANAさま

＞このセルに入力されてくる文字は、毎回同じでしょうか？
はい、同じです。
置換をかけている4種類の物品が、様式１と２のタイプになります。
それ以外の物品が、様式３になります。
様式３の物品名は、サニサーラ（Ｗ）４０ｍｌという感じで、
薬品コードなどは入っていないので、置換せずそのまま使用しています。

＞VLOOUP関数で参照させることにすると
＞容量部分も共通化が出来ると思いますが、どうなんでしょう？
この、「容量部分の共通化」というのはどういう意味でしょうか？
5kgとか１\x{fffd}gとか、それぞれの物品の容量の部分のマクロのことでしょうか。

＞ずれている場合は、データの開始行も一緒にずれるのでしょうか？
はい、そうです。
データが表になっているので、ずれていればすぐにわかります。
表の開始位置が通常はA1からなのに対し、C5とかD5とか開始位置が変わっているという状態です。
確認したところ、シートの真ん中にあった方が、見やすいのではないか？という配慮だそうです。
これに関しては、事務の方にいつもA1に貼付けてくれるよう依頼したので、
多分、今後はなくなるはず！と思っています。
データのシート名に関しては、事務の方では統一は難しそうなので、
こちらでしっかり確認していくしかないな、と考えています。
（Machi)

---

 ＞この、「容量部分の共通化」というのはどういう意味でしょうか？ 
 それぞれの商品によってコードを変えているのは
 商品によって容量が違っているからですよね。

 具体的には、表をもう一つ作って　最初の列に
 　　900709-1 ウォシュボンピンク 5kg・23915 (個)
 の様に、もらうデータに入力されているものを羅列。
 たとえば、次の列に容量
 　　5
 そして、その次の列に人が見てわかりやすい様に変更した文字
 　　ウォシュボンピンク 5kg
 を入れておきます。

 Sheet1にデータをすべて集めた後
 使用量を出す列には
 　=数量のセル*VLOOKUP(品名のセル,表の範囲,2,FALSE)
 人が見る品名の列には
 　=VLOOKUP(品名のセル,表の範囲,3,FALSE)
 といった式をマクロでいれる。

 すると、データを整理する部分のコードは様式の数だけ(二つだけ)用意しておけば良いですよね？

 また、何か変更があったり　追加があった場合も
 この表を変更するだけで対応出来ると思いますし。

 ＞シートの真ん中にあった方が、見やすいのではないか？という配慮だそうです。 
 ＞これに関しては、事務の方にいつもA1に貼付けてくれるよう依頼したので
 でしたら良かったですね。

 ＞データのシート名に関しては、事務の方では統一は難しそうなので、
 これは、データを整理する部分のコードが二つ（あるいは三つ）にまとめられるなら
 どちらの様式なのか判断して目的の方を自動的に実行させる様に出来ると思います。

 まずは、データを整理するコードが二つに出来るか、検討してみて下さい。
 その後、どのセルがどうなっている時どちらの様式と判断出来るのか　教えてください。

 (HANA)

---

HANAさま

＞すると、データを整理する部分のコードは様式の数だけ(二つだけ)用意しておけば良いですよね？

HANAさまに言われたとおりに表を作り、
よくわからないながらも、取りあえずVLOOKUPを入れてみて、
やっと、なるほど!!こういうことだったんだ。とわかりました。
便利なものですね〜。感動します、ほんとに。

２つの様式分のデータ整理用マクロは、
使用量を掛けていた部分を削除して、こんな感じになりました。

上から3行目から7行目までが、様式によって変わります。
Sub 消毒薬()

    Dim mxR As Long
    Columns("A:B").Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
    Range("A8").Value = Range("F6").Value   
    Range("B8").Value = Range("E4").Value  
    Rows("1:6").Delete Shift:=xlUp
    Range("C:C,E:N,P:Q").Delete Shift:=xlToLeft
    Range("A1").Value = "商品名"
    Range("B1").Value = "出庫月"
    Range("C1").Value = "部署"
    Range("D1").Value = "出庫数"
    Range("E1").Value = "金額"
    Range("F1").Value = "使用量"
    Range("G1").Value = "表示病棟名"
    Range("H1").Value = "表示商品名"

    mxR = Range("C" & Rows.Count).End(xlUp).Row

    Range("A2:A" & mxR).Value = Range("A2")
    Range("B2:B" & mxR).Value = Range("B2")
違う部分は、
Columns("A:A").Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
    Range("A5").Value = Range("B2").Value 
    Columns("C:C").Select
    Selection.Copy
    Columns("F:F").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False

    Rows("1:3").Delete Shift:=xlUp
    Range("B:D,G:G,I:J,L:M").Delete Shift:=xlToLeft　以上です。

参照させる部分は、昇順並べ替えも入ってますが、以下で良いでしょうか？
対応表は、A2からC10まで入力してあって、HANAさまのご提案通り、
A商品名、B容量、C表示商品名の順で入れてあります。
H3からI75には、部署名の対応表があります。
Dim mxR As Long

    mxR = Range("C" & Rows.Count).End(xlUp).Row
    Range("G3:G" & mxR).Select
    Selection.FormulaR1C1 = _
        "=IF(COUNTIF(対応表!R3C8:R75C8,RC[-4]),VLOOKUP(RC[-4],対応表!R3C8:R75C9,2,FALSE),""不明"")"

    Range("F3:F" & mxR).Select
    Selection.FormulaR1C1 = "=RC[-2]*VLOOKUP(RC[-5],対応表!R2C1:R10C3,2,FALSE)"

    Range("H3:H" & mxR).Select
    Selection.FormulaR1C1 = "=VLOOKUP(RC[-7],対応表!R2C1:R10C3,3,FALSE)"

    Rows("1:1").Delete Shift:=xlUp
    Cells.Select
    ActiveWorkbook.Worksheets("Sheet1").Sort.SortFields.Clear
    ActiveWorkbook.Worksheets("Sheet1").Sort.SortFields.Add Key:=Range("G2:G300") _
        , SortOn:=xlSortOnValues, Order:=xlAscending, CustomOrder:= _
        "Ａ５,ＮＩＣＵ,Ａ６,Ａ７,Ａ８,Ｂ３,ＩＣＵ,Ｂ４,Ｂ５,Ｂ６,Ｃ２,Ｃ３,Ｃ４,Ｃ５,Ｅ４,西５,ＨＤ,ＥＲ,手術室,外来", DataOption _
        :=xlSortNormal
    With ActiveWorkbook.Worksheets("Sheet1").Sort
        .SetRange Range("A1:H300")
        .Header = xlYes
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
以上です。

＞どのセルがどうなっている時どちらの様式と判断出来るのか　教えてください。
物品別シートの元データの部分で良いのでしょうか？
様式１，２では、常にA1セルに[9]ＳＰＤと入力されています。
様式３では、
出庫があった場合は、A1のセルに必ず施設名が入ります。
出庫がない場合は、出庫なし、出庫数なしなど、毎回違う言葉が違うセルに入力されています。これは、事務の方が入力するわけではなく元データそのものなんだそうです。
（Machi)

---

 もう少し考えを変えても良いでしょうか？

 今は、商品毎のシートでデータを整理して
 整理されたデータを Sheet1 にコピーしてますよね？
 　　もともと 商品毎に分かれたシートから部署毎に抽出予定でしたので。

 ですが　こうなると、直接 Sheet1にコピーしながらデータを作っていけば良いんじゃないでしょうか？
 そしたら、元のシートがそのまま残るので　何か問題（列がずれているパターンだった　等）
 があった時に、手作業での修正処理が簡単になると思います。

 そこで
 「消毒薬(様式1,2？)」は、
 　　A列(商品名)に D6
 　　B列(出庫月)に C4
 　　C列(部　署)に D8以降
     D列(出庫数) 　空き（後で数式を入れる）
 　　E列(金　額)に ・・・・
 の様に元のシートからの対応を書いてみてもらえますか？

 そして、Sheet1のデータには　あとからわかりやすい様に
 元シート名を入れる列も追加しておくのが良いと思います。

 ＞参照させる部分は、昇順並べ替えも入ってますが、以下で良いでしょうか？ 
 そうですね。
 病棟名を参照する部分は、COUNTIF関数でエラーチェックをしていますが
 出庫数と商品名を参照する部分はエラーチェックをしてないので
 （まぁ、エラーになるだけですが。。。）エラーチェックを入れておいても良いかもしれません。

 また、マクロの記録から作っているので　どうしても R1C1形式で記録されています。
 セルに入力する様な形に直しておいた方がわかりやすい。。。かな？
    Range("G3:G" & mxR).Formula = _
        "=IF(COUNTIF(対応表!$H$3:$H$75,C3),VLOOKUP(C3,対応表!$H$3:$I$75,2,FALSE),""不明"")"
 って感じで。

 この「75」の部分も変数にして　増減に対応できるようにしたいですね。
 （これはもう少し後の話にしますが。）

 ＞物品別シートの元データの部分で良いのでしょうか？
 はい、そのつもりで書きました。

 ＞様式１，２では、常にA1セルに[9]ＳＰＤと入力されています。 
 これは「消毒薬」マクロを実行するシート　って事でしょうか？

 ＞様式３では、出庫があった場合は、A1のセルに必ず施設名が入ります。
 出庫が無い場合は、Sheet1に何かデータを追加しますか？
 また、出庫が無かった場合　8行目以降（？）のデータはどの様になっているのでしょう？

 (HANA)

---

HANAさま
＞＞様式１，２では、常にA1セルに[9]ＳＰＤと入力されています。
＞これは「消毒薬」マクロを実行するシート　って事でしょうか？
こちらが「石鹸」マクロを実行するシートです。

＞出庫が無い場合は、Sheet1に何かデータを追加しますか？
Sheet1にデータを追加することはないです。
＞また、出庫が無かった場合　8行目以降（？）のデータはどの様になっているのでしょう？
出庫がなかった場合は、「出庫なし」などの文字がセルのどこかに入力されていますが、
それ以外は全く何も入力されていない空シートです。

＞元のシートからの対応を書いてみてもらえますか？
元シートからの対応といいますと、以下のような書き方で伝わりますか？
(見当違いな返答でしたらすみません。)
Sub 消毒薬()

    Dim mxR As Long
    Columns("A:B").Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove　→商品名と出庫月を移すための列を作成し、
    Range("A8").Value = Range("F6").Value   '→元D6の商品名をA8に移し、
    Range("B8").Value = Range("E4").Value   '→元C4の出庫月をB8に移し、
    Rows("1:6").Delete Shift:=xlUp　→不要になった1-6行を削除して、
    Range("C:C,E:N,P:Q").Delete Shift:=xlToLeft　→不要なデータと空の列を削除して、
    Range("A1").Value = "商品名"　→（D6から移した商品名がA2にのみ入力されている列）
    Range("B1").Value = "出庫月"　→（C4から移した出庫月(文字列)がB2にのみ入力されている列）
    Range("C1").Value = "部署"　→（元はB8列に入力されていた各部署名が入力されている列）
    Range("D1").Value = "出庫数"　→（元はI8列に入力されていた出庫数が入力されている列）、
    Range("E1").Value = "金額"　→（元はP8列に入力されていた金額が入力されている列）
    Range("F1").Value = "使用量"　→空の列（VLOOKUPが入る部分）で、
    Range("G1").Value = "表示病棟名"　→空の列（VLOOKUPが入る部分）で、
    Range("H1").Value = "表示商品名"　→空の列（VLOOKUPが入る部分）で、
    mxR = Range("C" & Rows.Count).End(xlUp).Row
    Range("A2:A" & mxR).Value = Range("A2") 　→商品名をコピー
    Range("B2:B" & mxR).Value = Range("B2")   →出庫月をコピー
End Sub
（Machi)

---

石鹸のデータ整理は、以下のように実施しています。
Sub 石鹸()
Dim mxR As Long
Columns("A:A").Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove　→商品名を入れるのに必要な列を追加し、
Range("A5").Value = Range("B2").Value '→元のA2に入力されていた商品名を移し、
Columns("C:C").Copy　→元はB列に入力されていた部署名をコピーし、
Columns("F:F").Select　→整理に都合が良いF列に可視セルのみコピー「=RIGHT(A7,LEN(A7)-FIND("／",A7))という数式で部署名が入っていたため」
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _

  :=False, Transpose:=False
    Rows("1:3").Delete Shift:=xlUp　→不要になった1-3行を削除し、
    Range("B:D,G:G,I:J,L:M").Delete Shift:=xlToLeft　→不要になった列を削除し、
    Range("A1").Value = "商品名"　→元のA2にあった商品名がA２にのみ入力されている列
    Range("B1").Value = "出庫月"　→元のD列にあった出庫月が入力されている列
    Range("C1").Value = "部署"　→元のB列に入っていて、F列に可視セルコピーされた部署名が入力されている列
    Range("D1").Value = "出庫数"　→元のG列にあった出庫数が入力されている列
    Range("E1").Value = "金額"　→元のJ列にあった金額が入力されている列
    Range("F1").Value = "使用量"　→空の列（VLOOKUPが入る列）
    Range("G1").Value = "表示病棟名"　→空の列（VLOOKUPが入る列）
    Range("H1").Value = "表示商品名"　→空の列（VLOOKUPが入る列）
    mxR = Range("D" & Rows.Count).End(xlUp).Row
    Range("A2:A" & mxR).Value = Range("A2")    →商品名をコピー
End Sub
（Machi）

---

 えっと、、、以降　様式１，２→様式１　様式３→様式２　と書かせてもらいますね。

 で、
 「様式１」が　石鹸マクロ　で、A1セルに　[9]ＳＰＤ　の入力があり
 「様式２」が　消毒薬マクロ　で、A1セルに共通のの入力は無い
 ですね。

 ＞出庫がなかった場合は、「出庫なし」などの文字がセルのどこかに入力されていますが、 
 これは　8行目より上の部分に入力されているのでしょうか？
 8行目よりも下に入力される事もあるのでしょうか？

 ＞それ以外は全く何も入力されていない空シートです。 
 データの見出し行も無しですか？

 ＞元シートからの対応といいますと、以下のような書き方で伝わりますか？ 
 すみません、せっかく書いていただきましたが　よくわかりません。

 ・様式１のどのセルに何が入力されているのか
 ・様式２のどのセルに何が入力されているのか
 一旦コードから離れて教えてください。

 様式１が石鹸マクロなので
 データの上部分が１〜３行
 ４行目がデータの見出しで
 ５行目以降がデータ　　・・・・ですか？

 商品名が　A2セル
 出庫月が　D4以降のセル
 部署　が　B4以降のセル
 出庫数が　G4以降のセル
 金額　が　J4以降のセル　・・・であってますか？

 で、A1セルに　[9]ＳＰＤ　の入力があるので、特定できるのですよね。

 様式２が消毒薬マクロで
 データの上部分が１〜６行
 ７行目がデータの見出しで
 ８行目以降がデータ　　・・・・ですか？

 商品名が　D6セル
 出庫月が　C4セル
 部署　が　B8以降のセル
 出庫数が　I8以降のセル
 金額　が　P8以降のセル　・・・であってますか？

 こちらは、A1セルに　[9]ＳＰＤ　の入力が無いシート　ですね。

 とりあえず、Sheet1にデータを作成する所までです。

 左端にSheet1 それ以降に商品毎のシート（もらった状態のもの）を配置して下さい。

 '------
Private Const MainSh = "Sheet1"
 '------
Sub データ収集()
Dim i As Long
    With Sheets(MainSh)
        .Range("A:I").Clear
        .Range("A1:I1").Value = _
            Array("商品名", "出庫月", "部署", "出庫数", "金額", "使用量", "表示病棟名", "表示商品名", "元シート")

        For i = 2 To Worksheets.Count
            Sheets(i).Select
            If Range("A1").Value = "[9]ＳＰＤ" Then
                If Range("G4").Value <> "" Then
                    Call 様式1  '石鹸マクロ
                End If
            Else
                If Range("B8").Value <> "" Then
                    Call 様式2  '消毒薬マクロ
                End If
            End If
        Next
        .Select
    End With
End Sub
 '------
Sub 様式1()
    '＝＝石鹸マクロ　4行目以降がデータ
    Dim RCnt As Long, myR As Long
    RCnt = Range("G" & Rows.Count).End(xlUp).Row - 3

    With Sheets(MainSh)
        myR = .Range("A" & Rows.Count).End(xlUp).Row + 1
        .Range("A" & myR).Resize(RCnt).Value = Range("A2").Value                '商品名
        .Range("B" & myR).Resize(RCnt).Value = Range("D4").Resize(RCnt).Value   '出庫月
        .Range("C" & myR).Resize(RCnt).Value = Range("B4").Resize(RCnt).Value   '部署
        .Range("D" & myR).Resize(RCnt).Value = Range("G4").Resize(RCnt).Value   '出庫数
        .Range("E" & myR).Resize(RCnt).Value = Range("J4").Resize(RCnt).Value   '金額
        .Range("I" & myR).Resize(RCnt).Value = ActiveSheet.Name                 'シート名
   End With
End Sub
 '------
Sub 様式2()
    '＝＝消毒薬マクロ　8行目以降がデータ
    Dim RCnt As Long, myR As Long
    RCnt = Range("B" & Rows.Count).End(xlUp).Row - 7

    With Sheets(MainSh)
        myR = .Range("A" & Rows.Count).End(xlUp).Row + 1
        .Range("A" & myR).Resize(RCnt).Value = Range("D6").Value                '商品名
        .Range("B" & myR).Resize(RCnt).Value = Range("C4").Value                '出庫月
        .Range("C" & myR).Resize(RCnt).Value = Range("B8").Resize(RCnt).Value   '部署
        .Range("D" & myR).Resize(RCnt).Value = Range("I8").Resize(RCnt).Value   '出庫数
        .Range("E" & myR).Resize(RCnt).Value = Range("P8").Resize(RCnt).Value   '金額
        .Range("I" & myR).Resize(RCnt).Value = ActiveSheet.Name                 'シート名
   End With
End Sub
 '------

 データ収集マクロを実行してもらうと、データをSheet1に集めます。

 (HANA)

---

HANAさま
＞・様式１のどのセルに何が入力されているのか
＞・様式２のどのセルに何が入力されているのか
＞一旦コードから離れて教えてください。
す、すみません。
元データのセルの位置を記載すれば良いのでしょうか？
【消毒薬　様式２】
C4に出庫月（文字列）
D6に物品名
B8以降に部署名
M8以降に出庫数
P8以降に金額
になります。
【石鹸　様式１】
A1に[9]ＳＰＤ
A2に物品名
（A5に業者名と部署名（多分B5で参照している場所だと思います。ｱｲｳｴｵ(株) ／ Ａ５病棟という入力方法です）
B5以降に部署名（=RIGHT(A5,LEN(A5)-FIND("／",A5))という数式が入っています）
D5以降に出庫月（文字列）
G5以降に出庫数
J5以降に金額
です。

＞データの見出し行も無しですか？
はい、そうです。
2012.01-2013.03までのデータにおいて、出庫なしのシートが12個ありますが、
全て入力方法が違いました。
出庫の有無にかかわらず、A1セルに施設名が入っていたり、
出庫がない物品シートそのものがなかったり、
表の見出しのみが入っていたり、不定のセルに「出庫なし」「使用なし」などの言葉が入っていたり…と
てんでバラバラなので、なんとも言えませんが
今のところ、8行目より下に入力があるものはなかったです。

＞データ収集マクロを実行してもらうと、データをSheet1に集めます。
実行したところ、使用量と表示病棟名、表示商品名の部分が＃REF!でした。
そして、同じ物品でも表示されている場合といない場合がありました。
（Machi)

---

 やっぱり少しずつ番地がずれてますね。
 直す所は分かりますか？
 適宜直してやってみてもらいたいのですが。
 （直してから、実行してもらっているかな？）

 ＞実行したところ、使用量と表示病棟名、表示商品名の部分が＃REF!でした。 
 それらの列は、今回のコードでは何もしていないので
 セルには何も表示されないと思いますが。。。？

 数式を入れるコードを追加されたなら　数式がおかしくないでしょうか？
 セルに入っている数式を確認してみて下さい。
 （#REF!だけが入っているでしょうか？）

 ＞同じ物品でも表示されている場合といない場合がありました。 
 同じシートのデータが、中途半端に転記されている　って事ですか？
 それとも、同じ物品で違うシートのデータで　転記されたシートとされていないシートがある
 って事ですか？

 データ収集コードの
                If Range("G4").Value <> "" Then
                If Range("B8").Value <> "" Then
 あたりのセル番地の関係かもしれません。

 これは、各様式で最終行を求める列の先頭のセルの値を確認してもらったら
 データの有無が分かるんじゃないかと思い入れてあります。

 こちらのセル番地も変更して、ステップインで実行しながら
 確認してみてもらえますか？

 その際、アクティブシートを切り替えて状態を確認した場合は
 元のシートをアクティブにし直してから、次の行に進む様にして下さい。

 (HANA) 

---

HANAさま
ステップインで見つつ、以下のように変更したところ
Sheet１にデータが集約されました。

Sub データ収集()
Dim i As Long

    With Sheets(MainSh)
        .Range("A1:I1").Value = _
            Array("商品名", "出庫月", "部署", "出庫数", "金額", "使用量", "表示病棟名", "表示商品名", "元シート")

        For i = 2 To Worksheets.Count
            Sheets(i).Select
            If Range("A1").Value = " [9]ＳＰＤ" Then
                If Range("A1").Value <> "" Then
                    Call 様式1  '石鹸マクロ
                End If
            Else
                If Range("B8").Value <> "" Then
                    Call 様式2  '消毒薬マクロ
                End If
            End If
        Next
        .Select
    End With
End Sub
 '------
Sub 様式1()
    '＝＝石鹸マクロ　5行目以降がデータ
    Dim RCnt As Long, myR As Long
    RCnt = Range("A" & Rows.Count).End(xlUp).Row - 4

    With Sheets(MainSh)
        myR = .Range("A" & Rows.Count).End(xlUp).Row + 1
        .Range("A" & myR).Resize(RCnt).Value = Range("A2").Value                '商品名
        .Range("B" & myR).Resize(RCnt).Value = Range("D5").Resize(RCnt).Value   '出庫月
        .Range("C" & myR).Resize(RCnt).Value = Range("B5").Resize(RCnt).Value   '部署
        .Range("D" & myR).Resize(RCnt).Value = Range("G5").Resize(RCnt).Value   '出庫数
        .Range("E" & myR).Resize(RCnt).Value = Range("J5").Resize(RCnt).Value   '金額
        .Range("I" & myR).Resize(RCnt).Value = ActiveSheet.Name                 'シート名
   End With
End Sub
 '------
Sub 様式2()
    '＝＝消毒薬マクロ　8行目以降がデータ
    Dim RCnt As Long, myR As Long
    RCnt = Range("B" & Rows.Count).End(xlUp).Row - 7

    With Sheets(MainSh)
        myR = .Range("A" & Rows.Count).End(xlUp).Row + 1
        .Range("A" & myR).Resize(RCnt).Value = Range("D6").Value                '商品名
        .Range("B" & myR).Resize(RCnt).Value = Range("C4").Value                '出庫月
        .Range("C" & myR).Resize(RCnt).Value = Range("B8").Resize(RCnt).Value   '部署
        .Range("D" & myR).Resize(RCnt).Value = Range("M8").Resize(RCnt).Value   '出庫数
        .Range("E" & myR).Resize(RCnt).Value = Range("P8").Resize(RCnt).Value   '金額
        .Range("I" & myR).Resize(RCnt).Value = ActiveSheet.Name                 'シート名
   End With
End Sub

以上です。（Ｍａｃｈｉ）

---

 上手くいきましたか。

 ただ
                If Range("A1").Value <> "" Then
                    Call 様式1  '石鹸マクロ
 の所は、A1セルではなく　A5セルとかが良いかもですね。

 ＞If Range("A1").Value = " [9]ＳＰＤ" Then
 を通って来ているので、A1セルの値を確認したのでは　必ずTRUEになっちゃいます。

 さて、次に　数式を入れるコードですが
 出来そうですか？

 Sub 数式を入れる()
 　変数の宣言等
 　With Sheets(MainSh)
   　数式を入れるコード
   End With
 End Sub

 的なものを作ってみて下さい。

 (HANA)

---

HANAさま

＞A1セルではなく　A5セルとかが良いかもですね。
わかりました。A5に修正します。

宿題が難しい(T_T)です〜。
＞変数の宣言等
→Dimほにゃららの部分でしょうか。
検索したところ、変数の宣言を入れないのは素人だ、とういうような記事をいくつか
読みましたが、変数？宣言？？はて？？？というほど　ど素人なので、諦めました。

コードですが
Sub 数式を入れる()

Cells.Select

    Cells.Replace What:="　", Replacement:="", LookAt:=xlPart, SearchOrder:= _
        xlByRows, MatchCase:=False, SearchFormat:=False, ReplaceFormat:=False
    Cells.Replace What:=" ", Replacement:="", LookAt:=xlPart, SearchOrder:= _
        xlByRows, MatchCase:=False, SearchFormat:=False, ReplaceFormat:=False

    Dim mxR As Long　　→これが所謂変数の宣言にあたるのでしょうか？
    mxR = Range("C" & Rows.Count).End(xlUp).Row

    Range("G2:G" & mxR).Formula = _
        "=IF(COUNTIF(対応表!$H$3:$H$75,C2),VLOOKUP(C2,対応表!$H$3:$I$75,2,FALSE),""不明"")"

    Range("F2:F" & mxR).Formula = _
        "=IF(COUNTIF(対応表!$A$2:$C$10,A2),D2*VLOOKUP(A2,対応表!$A$2:$C$10,2,FALSE))"

    Range("H2:H" & mxR).Formula = _
        "=VLOOKUP(A2,対応表!$A$2:$C$10,3,FALSE)"
→ここもIF COUNTIF…を入れるべきなのでしょうが、
Range("H2:H" & mxR).Formula = _
        "=IF(COUNTIF(対応表!$A$2:$C$10,A2)VLOOKUP(A2,対応表!$A$2:$C$10,3,FALSE))"
を入れると「アプリケーションまたはオブジェクト定義エラーです」というエラーに
なってしまい、よくわからないためそのままにしてしまいました。

End Sub
色々教えていただいているのに、
さっぱり身につかなくて申し訳ないです。
（Machi)

---

 ＞Dim mxR As Long　　→これが所謂変数の宣言にあたるのでしょうか？
 そうです。

 エクセルに
 「mxRって変数を使うよ。
 　この中には Long（ 長整数型： -2,147,483,648〜2,147,483,647の整数）を入れるよ。」
 って意思表示をします。

 すると、「こんなものを入れるよ」と言っていた以外のものを入れようとすると
 「違うもの入れようとしてるよ」と教えてくれるので、間違いに気づきやすいです。

 また、コードを書く所の先頭（一行目）に
 「Option Explicit」
 を入れておいてください。（きっと今は無いと思いますので。）

 これがあると、宣言していない変数が使えなくなります。
 例えば　mxRと書くつもりだったのに間違えて　宣言していない mcR なんて書くと
 「そんな変数使うって聞いてないよ」と怒られますので
 これまた間違いに気づきやすくなります。

 ＞"=IF(COUNTIF(対応表!$A$2:$C$10,A2)VLOOKUP(A2,対応表!$A$2:$C$10,3,FALSE))"
 ここは、数式なので　まず　ワークシート上で数式を作ってみないといけないですね。

 IF関数は、IF(論理式, [真の場合], [偽の場合])と言う書式です。
 書いておられる式だと、「,」の位置でわかれるので
 　論理式・・・・COUNTIF(対応表!$A$2:$C$10,A2)VLOOKUP(A2,対応表!$A$2:$C$10,3,FALSE)
 　真の場合
 　偽の場合
 ってなってますね。

 "=IF(COUNTIF(対応表!$A$2:$C$10,A2)VLOOKUP(A2,対応表!$A$2:$C$10,3,FALSE))"
      ~~~~~~~~~COUNTIFの式~~~~~~~~~-------------VLOOKUPの式-------------

 G列に入れた式だと
 "=IF(COUNTIF(対応表!$H$3:$H$75,C2),VLOOKUP(C2,対応表!$H$3:$I$75,2,FALSE),""不明"")"
      ~~~~~~~~~COUNTIFの式~~~~~~~~~,-------------VLOOKUPの式-------------,^^不明^^

 F列に入れた式だと
 "=IF(COUNTIF(対応表!$A$2:$C$10,A2),D2*VLOOKUP(A2,対応表!$A$2:$C$10,2,FALSE))"
      ~~~~~~~~~COUNTIFの式~~~~~~~~~,--------------VLOOKUPの式---------------

 ですね。

 VLOOKUP関数は　範囲の先頭列で検索値を探しますが　見つからなかった場合　エラーになります。
 エラーの表示をなくすために、範囲の先頭列で検索値を探し(COUNTIF)
 見つかった場合(COUNTIIF関数の結果が1以上だった場合)VLOOKUP関数を計算して結果を得ます。
 見つからなかった場合(COUNTIF関数の結果が0だった場合)「なかったよ」メッセージを表示します。

 そのメッセージが、G列に入れた式だと「不明」にあたります。

 F列に入れた式は、COUNTIF関数で調べる範囲が表全体になっているので
 VLOOKUP関数で検索する範囲（先頭列）と合わせておいた方が良いと思います。

 また、範囲内に検索値が無かった場合　特に何も指定していないので「FALSE」が表示されます。
 ここは何かわかりやすい文字が表示される様にしておいた方が良いと思います。

 で、H列用の式も作れると思いますが　どうでしょう？

 ＞色々教えていただいているのに、 
 ＞さっぱり身につかなくて申し訳ないです。
 つかみどころがないかもしれませんが、私が要求している事は　どんどん変わってます。
 例えば、ずっと足し算を教えていて「じゃあ　この足し算をやってみて」と言う感じではなく
 足し算を教え→やってみてもらって→引き算を教え→やってみてもらって→掛け算を教え→。。。。
 で、やってみた時にわからないのは　身についてないからじゃないですよね。

 テーマを「算数」と大きくとると「いつまでたっても算数わからないな」ってなりますが
 そういうとらえ方はしないです。
 「掛け算初めてだから、わからなくて当然だよね」と思います。

 むしろ、私があわててついて行ってる感じです。

 ちなみに
 ＞Cells.Select 
 は、無くても大丈夫だと思いますが？

 このコードを実行するときの注意点としては
 「どのシートに対して処理するのか」書いていないので
 アクティブシートに対して実行されます。

 事前にSheet1をアクティブにしておかないといけないですね。

 (HANA)

---

HANAさま
＞足し算を教え→やってみてもらって→引き算を教え→やってみてもらって→掛け算を教え→。。。。
＞で、やってみた時にわからないのは　身についてないからじゃないですよね。
やさしいです〜。ありがとうございます！
が、しかし。足し算から引き算に移ったことにも気が付けないMachiです(>_<)。

Option Explicit　→これは、VBEの標準モジュールから作成すると自動的についてきてました。
なんだろこれ？と思いつつも自分で消去してましたが、大切なものだったんですね。
Private Const MainSh = "Sheet1"　
Sub 数式を入れる2()

  Dim mxR As Long

   With Sheets(MainSh)
   Sheets("Sheet1").Select

    Cells.Replace What:="　", Replacement:="", LookAt:=xlPart, SearchOrder:= _
        xlByRows, MatchCase:=False, SearchFormat:=False, ReplaceFormat:=False
    Cells.Replace What:=" ", Replacement:="", LookAt:=xlPart, SearchOrder:= _
        xlByRows, MatchCase:=False, SearchFormat:=False, ReplaceFormat:=False

    mxR = Range("C" & Rows.Count).End(xlUp).Row    
    Range("G2:G" & mxR).Formula = _
        "=IF(COUNTIF(対応表!$H$3:$H$75,C2),VLOOKUP(C2,対応表!$H$3:$I$75,2,FALSE),""不明"")"       
    Range("F2:F" & mxR).Formula = _
         "=IF(COUNTIF(対応表!$A$2:$B$10,A2),D2*VLOOKUP(A2,対応表!$A$2:$B$10,2,FALSE),""？"")"       
    Range("H2:H" & mxR).Formula = _
         "=IF(COUNTIF(対応表!$A$2:$C$10,A2),VLOOKUP(A2,対応表!$A$2:$C$10,3,FALSE),""？"")"    
    End With
End Sub

＞事前にSheet1をアクティブにしておかないといけないですね。
Private Const MainSh = "Sheet1"　……
With Sheets(MainSh)
この部分が、そうなのかなぁと思っていたのですが、
他のシートをアクティブにして実行すると、そのシートで実行されちゃうので
違うんだな。と思い、Sheets("Sheet1").Select　を入れてみました。
（Machi)

---

 ＞Option Explicit　→これは、VBEの標準モジュールから作成すると自動的についてきてました。 
 VBEの設定で
 　ツール(T)→オプション(O) |編集|タブで
 　■変数の宣言を強制する(R)
 にチェックがついていると、「Opetion Explicit」が勝手につきます。
 活用してみて下さい。

 ＞With Sheets(MainSh) 
 ＞この部分が、そうなのかなぁと思っていたのですが、 
 そうそう。それがポイントなんですが。。。。

 例えば
 　Range("A1").Value = "○"
 って書くと、
 　アクティブシートのA1セルに「○」が書き込まれます。
 セルの指定(A1)と言う記述はありますが
 「どのシートの」と言う記述は無いですよね。

 次に
 　Sheets("Sheet1").Range("A1").Value = "○"
 って書くと
 　Sheet1と言うシートのA1セルに「○」が書き込まれます。
 今度は「Sheet1の！！」と書いてあるので
 どのシートがアクティブになっていても Sheet1のA1セルに書き込まれます。

 そして
 　Sheets("Sheet1").Range("A1").Value = "○"
 　Sheets("Sheet1").Range("B1").Value = "△"
 　Sheets("Sheet1").Range("C1").Value = "□"
 　Sheets("Sheet1").Range("D1").Value = "◎"
 で、A1:D1に各文字が書き込まれますが　共通している Sheets("Sheet1") 部分を
 　With Sheets("Sheet1")
 　   .Range("A1").Value = "○"
 　   .Range("B1").Value = "△"
 　   .Range("C1").Value = "□"
 　   .Range("D1").Value = "◎"
 　End With
 こんな感じでまとめることができます。

 最初と   Range("A1").Value = "○"
 今回は  .Range("A1").Value = "○"
 Rangeの前に「.」がついていますね。

 この前に　Withの後ろに書いてあるのが　有ると思って下さい。

 データ収集マクロを見てもらうと
     With Sheets(MainSh)
        .Range("A1:I1").Value = _
 A1:I1セルは、Sheets(MainSh)・・・MainSh = "Sheet1"・・・のシートのセルの事で
 その後
            Sheets(i).Select
            If Range("A1").Value = " [9]ＳＰＤ" Then
 のA1セルは、アクティブシートのセルの事です。

 今回は、アクティブシートを切り替えながら作業した方が
 分かりやすいかと思い、その様なコードにしてあります。
 （一般的には　アクティブシート・アクティブセル等の移動は
 　行わない方が良いと言われます。）

 「MainShの！！」の「.」を必要な所につけてもらうと
 Sheets("Sheet1").Select　が不要になりますので
 やってみて下さい。

 「数式を入れる2」の数式ですが
 F:H列に入れる式の COUNTIF関数で数える範囲が
 複数列になっています。
 先にも書きましたが、VLOOKUP関数の先頭列のみにして下さい。

 それから、上の方でつぶやきましたが
 新しい変数を用意して
 　新しい変数 = Sheets("対応表").Range("H" & Rows.Count).End(xlUp).Row
 と書くと、対応表のH列の入力がある最後の行が取得できます。
 たぶんこれは「75」になりますよね？
 数式の
    .Range("G2:G" & mxR).Formula = _
        "=IF(COUNTIF(対応表!$H$3:$H$75,C2),VLOOKUP(C2,対応表!$H$3:$I$75,2,FALSE),""不明"")"  
                                    ~~                               ~~
 この2ヶ所に入ってほしい値ですので、
        "=IF(COUNTIF(対応表!$H$3:$H$" & 新しい変数 & ",C2),VLOOKUP(C2,対応表!$H$3:$I$" & 新しい変数 & ",2,FALSE),""不明"")"
 こんな感じで埋め込んでみて下さい。

 (HANA) 

---

HANAさま
＞■変数の宣言を強制する(R)
→これは、チェックが入っていました。
だから、いつも自動的に入ってたのですね。

＞F:H列に入れる式の COUNTIF関数で数える範囲が 複数列になっています。
→すみません、コピー元を間違えていました。
"=IF(COUNTIF(対応表!$A$2:$B$10,A2)これを、"=IF(COUNTIF(対応表!$A$2:$A$10,A2)で、
"=IF(COUNTIF(対応表!$A$2:$C$10,A2)これを、"=IF(COUNTIF(対応表!$A$2:$A$10,A2)です。

データ収集のマクロを見ながら、以下のようにしました。
変数の定義を挿れる場所がわからないのですが、取敢えずです。
病棟名のVLOOKUPの部分は、不明→その他に変更しました。

Option Explicit
Private Const MainSh = "Sheet1"

Sub 数式を入れる2()

  Dim mxR As Long, 新しい変数 As Long
  mxR = Range("C" & Rows.Count).End(xlUp).Row

   With Sheets(MainSh)
    .Cells.Replace What:="　", Replacement:="", LookAt:=xlPart, SearchOrder:= _
        xlByRows, MatchCase:=False, SearchFormat:=False, ReplaceFormat:=False
    .Cells.Replace What:=" ", Replacement:="", LookAt:=xlPart, SearchOrder:= _
        xlByRows, MatchCase:=False, SearchFormat:=False, ReplaceFormat:=False
   新しい変数 = Sheets("対応表").Range("H" & Rows.Count).End(xlUp).Row
    .Range("G2:G" & mxR).Formula = _
         "=IF(COUNTIF(対応表!$H$3:$H$" & 新しい変数 & ",C2),VLOOKUP(C2,対応表!$H$3:$I$" & 新しい変数 & ",2,FALSE),""その他"")"
    .Range("F2:F" & mxR).Formula = _
         "=IF(COUNTIF(対応表!$A$2:$A$10,A2),D2*VLOOKUP(A2,対応表!$A$2:$B$10,2,FALSE),""？"")"
    .Range("H2:H" & mxR).Formula = _
         "=IF(COUNTIF(対応表!$A$2:$A$10,A2),VLOOKUP(A2,対応表!$A$2:$C$10,3,FALSE),""？"")"
    End With
End Sub

Dimほにゃらら…定義の部分は、いくつまで並べることができるのでしょうか？
物品種類が追加されてきたので、F列とH列の部分も同様に、
最終行を取得させたいのですが、例えば
Dim mxR As Long, 新しい変数 As Long,物品 As Long　として、
物品 = Sheets("対応表").Range("A" & Rows.Count).End(xlUp).Row
　　.Range("F2:F" & mxR).Formula = _
　"=IF(COUNTIF(対応表!$A$2:$A$" & 物品 & ",A2),D2*VLOOKUP(A2,対応表!$A$2:$B$" & 物品 & ",2,FALSE),""？"")"
　　.Range("H2:H" & mxR).Formula = _
　"=IF(COUNTIF(対応表!$A$2:$A$" & 物品 & ",A2),VLOOKUP(A2,対応表!$A$2:$C$" & 物品 & ",3,FALSE),""？"")"
こんな感じに挿れてしまっても、良いものなのでしょうか？
（Machi)

---

 ＞Dimほにゃらら…定義の部分は、いくつまで並べることができるのでしょうか？ 
 。。。考えた事無いですが、いくつでも大丈夫だと思いますよ。
 後で見やすい様に、グループ（？）で行を分けても良いと思います。
    Dim mxR As Long
    Dim 新しい変数 As Long, 物品 As Long
 あと「新しい変数」ってのも適当な名前に変更して下さいね。

 コードを見てみると「対応表」と言う文字が何度か出てきますので
 　Private Const MainSh = "Sheet1" 
 の様に変数として出しておいても良いかもしれないですね。
 　Private Const 表Sh = "対応表"
 としておけば
   物品 = Sheets("対応表").Range("A" & Rows.Count).End(xlUp).Row
     ↓
   物品 = Sheets(表Sh).Range("A" & Rows.Count).End(xlUp).Row

 　"=IF(COUNTIF(対応表!$A$2:$A$" & 物品 & ",A2),D2*VLOOKUP(A2,対応表!$A$2:$B$" & 物品 & ",2,FALSE),""？"")"
     ↓
 　"=IF(COUNTIF(" & 表Sh & "!$A$2:$A$" & 物品 & ",A2),D2*VLOOKUP(A2," & 表Sh & "!$A$2:$B$" & 物品 & ",2,FALSE),""？"")"

 って感じでしょうか。

 まぁ、対応表があるシート名が変わる心配をするよりは　表の位置が変わる心配をする方が
 現実味がある様な気もしますが。

 (HANA)

---

HANAさま
＞あと「新しい変数」ってのも適当な名前に変更して下さいね。
はい。こちらは部署名にしました。

＞まぁ、対応表があるシート名が変わる心配をするよりは　表の位置が変わる心配をする方が
＞現実味がある様な気もしますが。
うぅ、そうですね…。
ここの配列は変えちゃダメ！！というコメントは
セルに入れてあるのですが、自分がいつ何をするかかなり心配です。

以下のように変更しました。

Option Explicit
Private Const MainSh = "Sheet1"
Private Const 表Sh = "対応表"

Sub 数式を入れる3()

  Dim mxR As Long
  Dim 部署名 As Long, 物品 As Long
  mxR = Range("C" & Rows.Count).End(xlUp).Row

   With Sheets(MainSh)
    .Cells.Replace What:="　", Replacement:="", LookAt:=xlPart, SearchOrder:= _
        xlByRows, MatchCase:=False, SearchFormat:=False, ReplaceFormat:=False
    .Cells.Replace What:=" ", Replacement:="", LookAt:=xlPart, SearchOrder:= _
        xlByRows, MatchCase:=False, SearchFormat:=False, ReplaceFormat:=False
   部署名 = Sheets(表Sh).Range("H" & Rows.Count).End(xlUp).Row
    .Range("G2:G" & mxR).Formula = _
         "=IF(COUNTIF(" & 表Sh & "!$H$2:$H$" & 部署名 & ",C2),VLOOKUP(C2," & 表Sh & "!$H$2:$I$" & 部署名 & ",2,FALSE),""その他"")"
    物品 = Sheets(表Sh).Range("A" & Rows.Count).End(xlUp).Row
    .Range("F2:F" & mxR).Formula = _
  "=IF(COUNTIF(" & 表Sh & "!$A$2:$A$" & 物品 & ",A2),D2*VLOOKUP(A2," & 表Sh & "!$A$2:$B$" & 物品 & ",2,FALSE),""？"")"
    .Range("H2:H" & mxR).Formula = _
  "=IF(COUNTIF(" & 表Sh & "!$A$2:$A$" & 物品 & ",A2),VLOOKUP(A2," & 表Sh & "!$A$2:$C$" & 物品 & ",3,FALSE),""？"")"
    End With
End Sub
以上です。（Ｍａｃｈｉ）

---

 かなり完成に近づいてきましたね。
 もう一息ですね！！

 並べ替えは、数式で入れた部署名の列で行っているでしょうか？

 今は、ユーザー設定リストを使って並べ替えを行っていると思います。
 ここも、もうひとつ　並べたい順に部署名を入力している表を作って
 MATCH関数等で何番目か番号を表示させるのはどうでしょう。
 　　コード内で、ユーザー設定リストを設定して使用する方法も
 　　あると思いますが、数式でやってしまった方が簡単だと思うので。

 すると、部署に追加が有った場合や　順番を変更する必要が有った時に
 コードを変更しなくて良くなりますよね。

 ちなみに、コード内でリストを設定する過去ログが、直近で
[[20130510092122]]　『VBAで並べ替えの順序を任意に指定したい』（シマリス）　
 他にもありますので、過去ログを探してみてもらえると良いかもしれません。

 ちなみに、現在セルには数式が入ったままになっていると思います。
 値にしておいた方が良い場合は全ての数式を入れ終わった後
 　.Range("F2:H" & mxR).Value = .Range("F2:H" & mxR).Value
 としてもらうと、値に変わります。

 さて、結局 Sheet1に全部署のデータが集まったことになりますので
 オートフィルタで絞り込むだけで、簡単に特定の部署のデータが確認
 出来る様になったと思います。

 そこでもう一度考えてもらいたいのが、部署毎にシートを分ける必要があるでしょうか？
 シート数が増えると「目的のシートを探す」と言う作業が困難になってくると思います。

 データタブの並べ替えとフィルタグループに「フィルタ」がありますが
 これが「オートフィルタ」ですよね。
 その隣に「詳細設定」と言うのが有ると思います。
 これが、以前のバージョンでは「フィルタオプションの設定」と言う名前でした。

 この機能を使うと、目的のデータだけ　特定のシートに簡単に抜き出す事が出来ます。
 例えば、A2セルに表示させたい部署名を入力する事にして
 　　A2セルに部署名が入力されたら、抽出マクロを実行して、指定されたデータを表示する
 と言う作りにしておくと、コードも簡単ですし
 データを確認したい時、シートを探さなくても良くなります。

 もちろん、その後の作業の関係で　シートが分かれている方が良いのなら
 部署ごとにシートを分けるコードを載せますが。

 (HANA)

---

HANAさま
＞もう一息ですね！！
ありがとうございます〜。HANAさまのおかげです。
もう一息で出来る頭脳がMachiにあることを祈ります(>_<)。

＞並べ替えは、数式で入れた部署名の列で行っているでしょうか？
はい、そうです。

＞ MATCH関数等で何番目か番号を表示させるのはどうでしょう。
エクセルのヘルプで、MATCH関数の部分を読みつつ、
対応表のE2E21にユーザー設定と同じ並びで部署名を入力しました。
試しに、その隣（F2以降）に数式を入れてみましたが、
検査値は、並び順に入力したE2で
検査範囲は、参照するSheet１の部署名がある列で、
照合の種類は、何を入れるか不明だけど、0が完全一致って書いてあるから、0を入れてみて
=MATCH(E2,Sheet1!$G$2:$G$132,0)　で１と返ってきました。
E2と同じ文字のの個数が返ってくるのかな？と思ったのですが
それだと3が返ってくるはずなので、何が返されているのかさっぱりわからず…。
はて、じゃあE2というセル名ではなく、Ａ５という文字を入れるのかしら？
とも考えたのですが、文字列を＊で囲んでもエラーになるので諦めました。

じゃ、次行ってみよーっと思い[[20130510092122]]を読みましたが…。

 """" & lst & """",って何のどこを指しているのでしょうか？？
とさらに混乱してきたのでいったん止めました。ほんとにトホホです。

＞そこでもう一度考えてもらいたいのが、部署毎にシートを分ける必要があるでしょうか？
＞その後の作業の関係で　シートが分かれている方が良いのなら…
これらのデータを、40人前後（半年〜１年で違う人に変わります）の
パソコン初心者（エクセル開くのも初めて的な）に、月１回使用してもらう必要があります。
彼らに確認したところ、
・所定のセルに文字を入力するのはイヤ。
・チェックボックスやプルダウン等で、選択して自分の部署を選ぶのもイヤ。
と言われてしまいまして。
タブに表記されている、自分の部署をクリックして
必要枚数印刷するのは、いいのだそうです。
(文字を入力したり、閉じるときに「保存しますか？」と聞かれたりするのがイヤなんだそうです。）
なので、あの方法になってしまったわけです。

ちなみにMachiとしては
＞例えば、A2セルに表示させたい部署名を入力する事にして…
こちらは大変魅力的です!!!
やり方はぜひ教えていただきたいです!!!(迷惑でなければ）。
（Machi)

---

 ＞＞ MATCH関数等で何番目か番号を表示させるのはどうでしょう。 
 ＞対応表のE2E21にユーザー設定と同じ並びで部署名を入力しました。 
 ＞試しに、その隣（F2以降）に数式を入れてみましたが、
 あらら、「試し」だから　対応表の方に数式を入れたのですか？
 Sheet1で使う数式なのでSheet1の方で作ってみて下さい。

 ビジョンがつかめていないっぽいので、補足として。。。
 　    　[A]      [B]      [C]      [D]      [E]      [F]
 [1]    部署      番号             対応表
 [2]     A7        4                番号     部署
 [3]     A8        5                 1        A5
 [4]     A5        1                 2        NICU
 [5]     A7        4                 3        A6
 [6]     NICU      2                 4        A7
 [7]     A7        4                 5        A8
                   ↑MATCH関数で順番を表示
 A:BがSheet1・D:Eが対応表だと思ってみて下さい。

 今は、A列を指定した順に並べていると思いますが
 関数でB列を表示させ　昇順に並べる事にすると
 「指定した順」に変更があった時に、コード内の
        "Ａ５,ＮＩＣＵ,Ａ６,Ａ７,Ａ８,Ｂ３,ＩＣＵ,Ｂ４,Ｂ５,Ｂ６,Ｃ２,Ｃ３,Ｃ４,Ｃ５,Ｅ４,西５,ＨＤ,ＥＲ,手術室,外来"
 とかを変更しなくてよくなるよね♪

 ってのが目標です。

 なので、B列（Sheet1の方）に、MATCH関数を入れますね。

 ＞対応表のE2E21にユーザー設定と同じ並びで部署名を入力しました。 
 と言う事なので（Sheet1の2行目に入れる式は）
 　　MATCH(検査値, 検査範囲, [照合の型])
 検査値が　 Sheet1のG2
 検査範囲が 対応表シートのE2:E21
 照合の型は 【完全に一致するもの】を探したいので　0
 =MATCH(G2,対応表!$E$2:$E$21,0)

 ↑の小さなサンプルの場合　検査範囲に E2:E7 とすると見出しも含まれるので
 B列に表示される番号が一つずつずれます。
 　部署:A7 を探した場合、E2セルから数えて5番目にあるので「5」が返されます。
 なんだか落ち着かないので、E3:E7と指定するのが良いと思います。

 また、Sheet1のG列は部署以外に「その他」も表示される事になっていますので
 E列の表に追加しておくか、ここもやはり COUNTIF関数と絡めてもらうと良いかもしれません。
 =IF(COUNTIF(対応表!$E$2:$E$21,G2),MATHC(〜〜〜),"その他")

 ＞じゃ、次行ってみよーっと思い[[20130510092122]]を読みましたが…。 
 数式案にして、こちらは一旦おいておきましょう。。。

 ＞タブに表記されている、自分の部署をクリックして必要枚数印刷するのは、いいのだそうです。
 了解です。
 コードの方は少し待って下さい。
 ＞＞例えば、A2セルに表示させたい部署名を入力する事にして… 
 の方が簡単なので、先にこちらを。。。

 まずは手作業でやってみて下さい。
 シート名を「抽出」と言う名前で書きますね。
 抽出シートのA1セルに Sheet1のG1セルの見出しをコピー
 抽出シートのA2セルに 部署名を一つ入力

 抽出シートを表示した状態で、「詳細設定」を開きます。
 　抽出先
 　　○選択範囲内(F)
 　　●指定した範囲(O)
   リスト範囲(L)    A1:A2
   検索条件範囲(C)  Sheet1!A:H
   抽出範囲(T)      B1
 を設定して「OK」を押します。

 上手く抽出出来たら、これをマクロの記録に取ってください。
 その際、「前回の結果を消す」作業から行ってもらえると良いと思います。
 　１．B:I列のデータを削除
 　２．抽出
 を記録に取ります。

 また、A2セルには入力規則で　対応表シートのE2:E21を
 リストで選べる様にしておくと良いかもしれません。

 思ったものが抽出できるマクロが記録出来たら
 コードを開くと、改造箇所が見つかると思います。

 (HANA)

---

HANAさま
返信が遅くなり申し訳ありません。
（アップしたと思っていたのに、プレビューで満足して閉じていたようです…）

＞なので、B列（Sheet1の方）に、MATCH関数を入れますね。
データ集約でB列に出庫月がはいっているので、
とりあえず、何も入っていなかったJ列に入れました。
数式を入れるのマクロに、以下のように挿入しましたが、これで良いでしょうか。
Option Explicit
Private Const MainSh = "Sheet1"
Private Const 表Sh = "対応表"
Sub 数式を入れる4()

  Dim mxR As Long
  Dim 部署名 As Long, 物品 As Long
  Dim 昇順 As Long
  mxR = Range("C" & Rows.Count).End(xlUp).Row
   With Sheets(MainSh)
    .Cells.Replace What:="　", Replacement:="", LookAt:=xlPart, SearchOrder:= _
        xlByRows, MatchCase:=False, SearchFormat:=False, ReplaceFormat:=False
    .Cells.Replace What:=" ", Replacement:="", LookAt:=xlPart, SearchOrder:= _
        xlByRows, MatchCase:=False, SearchFormat:=False, ReplaceFormat:=False
    .Range("J1") = "昇順"
　　部署名 = Sheets(表Sh).Range("H" & Rows.Count).End(xlUp).Row
    .Range("G2:G" & mxR).Formula = _
         "=IF(COUNTIF(" & 表Sh & "!$H$2:$H$" & 部署名 & ",C2),VLOOKUP(C2," & 表Sh & "!$H$2:$I$" & 部署名 & ",2,FALSE),""その他"")"
   物品 = Sheets(表Sh).Range("A" & Rows.Count).End(xlUp).Row
    .Range("F2:F" & mxR).Formula = _
  "=IF(COUNTIF(" & 表Sh & "!$A$2:$A$" & 物品 & ",A2),D2*VLOOKUP(A2," & 表Sh & "!$A$2:$B$" & 物品 & ",2,FALSE),""？"")"
    .Range("H2:H" & mxR).Formula = _
  "=IF(COUNTIF(" & 表Sh & "!$A$2:$A$" & 物品 & ",A2),VLOOKUP(A2," & 表Sh & "!$A$2:$C$" & 物品 & ",3,FALSE),""？"")"
　昇順 = Sheets(MainSh).Range("G" & Rows.Count).End(xlUp).Row
   .Range("J2:J" & mxR).Formula = "=MATCH(G2," & 表Sh & "!$E$3:$E$23,0)"

 End With
    With Sheets(MainSh)
        .Sort.SortFields.Add Key:=Range("J2"), _
        SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
    End With

    With ActiveWorkbook.Worksheets("Sheet1").Sort　→ここも「．」で続けたいと思ったのですがエラーになってしまいできませんでした。
        .SetRange Range("A1:J111")
        .Header = xlYes
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
End Sub
以上です。

＞抽出シートのA1セルに Sheet1のG1セルの見出しをコピー…
これ以降、HANAさまが書いてある通りにやってみたところ、
Sub 抽出()

    Sheets("抽出").Select
    Columns("B:I").Select
    Selection.ClearContents
    Range("A1").Select
    ActiveCell.FormulaR1C1 = "表示病棟名"
    Range("A2").Select　→ここは、リストにしてあります。
    Range("A1:A2").AdvancedFilter Action:=xlFilterCopy, CriteriaRange:=Sheets( _
        "Sheet1").Columns("A:H"), CopyToRange:=Range("B1"), Unique:=False
End Sub
以上を行うと、
B1セルにA1セルと同じ内容、B2セルにA2セルと同じ内容が表示されます。
それ以外のデータは表示されないのですが、今回はこれで合っていますか？（Machi)

---

HANAさま
肝心の抽出させる部分を忘れていました。

 　　○選択範囲内(F)
 　　●指定した範囲(O)
   リスト範囲(L)    Sheet1!A:H
   検索条件範囲(C)  抽出！A1:A2
   抽出範囲(T)      Sheet1!B1:I1
で、以下をマクロに入れると
Sub 抽出6()
    Sheets("抽出").Select
    Range("A2").Select
    Sheets("Sheet1").Columns("A:H").AdvancedFilter Action:=xlFilterCopy, _
        CriteriaRange:=Range("A1:A2"), CopyToRange:=Range("B1:I1"), Unique:=False
End Sub
以上です。はじめは、
Option Explicit
Private Const 抽出Sh = "抽出"
Sub 抽出5()
  Dim 抽出 As Long
  抽出 = Sheets(抽出Sh).Range("A2")　→ここで型が一致しませんとエラーが出る
    Sheets("Sheet1").Columns("A:H").AdvancedFilter Action:=xlFilterCopy, _
        CriteriaRange:=Range("A1:A2"), CopyToRange:=Range("B1:I1"), Unique:=False
End Sub
とやってみたのですが、付け焼刃では対応できませんでした（T_T)。（Machi)

---

 ＞→ここも「．」で続けたいと思ったのですがエラーになってしまいできませんでした。
 そうですね。ここは少し難易度が高いと思います。
 2003までのソートの記録の方がつつきやすいです。
 でも、2007 or 2010 との事ですので仕方ないですね。。。

 まず、With から出してみて、Range の前にも「どのシート！！」の明記をしてみますと
        Sheets(MainSh).Sort.SortFields.Add Key:=Sheets(MainSh).Range("J2"), _
            SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
        Sheets(MainSh).Sort.SetRange Sheets(MainSh).Range("A1:J111")
        Sheets(MainSh).Sort.Header = xlYes
        Sheets(MainSh).Sort.MatchCase = False
        Sheets(MainSh).Sort.Orientation = xlTopToBottom
        Sheets(MainSh).Sort.SortMethod = xlPinYin
        Sheets(MainSh).Sort.Apply
 こんな感じに成ります。
 「Sheets(MainSh).Sort」を Wiht の後ろにまとめたい所ですが
 　　Key:=Sheets(MainSh).Range("J2")
 　　Sheets(MainSh).Range("A1:J111")
 の所が「.Sort」がついて無いのでためらってしまう感じですね。

 With Sheets(MainSh)　としても良いですが、こんな感じにしてみて下さい。
        With Sheets(MainSh).Sort
            .SortFields.Add Key:=.Parent.Range("J2"), _
                SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
            .SetRange .Parent.Range("A1:J111")
            .Header = xlYes
            .MatchCase = False
            .Orientation = xlTopToBottom
            .SortMethod = xlPinYin
            .Apply
        End With

 あと、A1:J111 の「111」は mxR の事ですよね？

 ソートの関連で行くと、マクロの記録をとった時 
 　　　ActiveWorkbook.Worksheets("Sheet1").Sort.SortFields.Clear
 ってのが、記録されていたと思います。
 重要なので、「.SortFields.Add」の前に入れておいて下さい。
 With Sheets(MainSh).Sort　の中に入れるので「.SortFields.Clear」を入れて下さいね。

 ((数式を入れる4))マクロに関して、細かい事を書くと
 　　　mxR = Range("C" & Rows.Count).End(xlUp).Row
 これは、MainShのセルの事なので（ですよね？）Withの中に入れて
 「どのシートの！！」を書く様にして下さい。

 それから
 　　　.Range("J1") = "昇順"
 これは、ここでするよりは((データ収集))マクロで
 1行目に見出しを入力する部分が有りますので
 そこで一緒にやっておいた方が良いと思います。

 抽出の方に関してですが
 ＞B1セルにA1セルと同じ内容、B2セルにA2セルと同じ内容が表示されます。
 ＞それ以外のデータは表示されないのですが、今回はこれで合っていますか？
 いや、合ってないですねＴＴ

 あ、私が説明を書き間違えてます。済みません。
 ＞肝心の抽出させる部分を忘れていました。 
 に書いてもらっている設定で正しく抽出出来ましたか？

 ちなみに、このコードは
 　抽出シートのA2セルの値が変わったら自動実行！！
 を考えているので、必ず　アクティブシート＝抽出シート　です。

 他のシートがアクティブな状態で実行する目論見が有るなら別ですが
 そうでないなら、
 　Private Const 抽出Sh = "抽出"
   Sheets("抽出").Select
 等は要らないと思います。

 また、((抽出6))の
   Range("A2").Select
 も要らないですね。

 折角なので((抽出5))の
 ＞Dim 抽出 As Long
 ＞抽出 = Sheets(抽出Sh).Range("A2")　→ここで型が一致しませんとエラーが出る
 の点について少し書きたいのですが
 長くなったのでもう少し後にします。

 でもって、スレもかなり長くなったので
 新しくたててもらって良いでしょうか？

 その際、現在出来ているコードは
 新しいスレに入れる様にして貰えると良いのですが。

 新規投稿して貰うと、URLが決まりますので
 こちらにリンクを貼っておいて貰えると良いと思います。
 　新スレには、旧スレのリンクを。。。

 (HANA)

---

HANAさま

＞でもって、スレもかなり長くなったので　新しくたててもらって良いでしょうか？
わかりました。
新しいスレのアドレスは
『データの整理方法について』で
https://www.excel.studio-kazu.jp/kw/20130529235735.html
にあります。

＞その際、現在出来ているコードは　 新しいスレに入れる様にして貰えると良いのですが。
現在出来ているコードを全部載せてしまったため、
またもや長文になってしまいました。
すみませんm(_ _)m.

---

コメント返信：

---

[ 一覧(最新更新順) ]

---

YukiWiki 1.6.7 Copyright (C) 2000,2001 by Hiroshi Yuki. Modified by kazu.