柔軟に働き方を選ぶ時代に必要なこと >>

元データ(DB)をA列の値で振り分け
別シート(印刷)に転記していく方法について教えてください。
以下のコードで転記は行えましたが1つの値で1つのシートを作成になってしまいます。
どこをどのように変更すればA列の値(一種類に1つのシートにまとめたい)に
1つのシートに転記となるかご教示お願いします。

Sub test01()
Dim sh1 As Worksheet
Dim sh2 As Worksheet
Set sh1 = Worksheets("DB")
Set sh2 = Worksheets("印刷")

d = sh1.Range("A65536").End(xlUp).Row
For i = 2 To d
sh2.Cells(6, "B") = sh1.Cells(i, "A")
sh2.Cells(10, "B") = sh1.Cells(i, "B")
sh2.Cells(10, "C") = sh1.Cells(i, "C")
sh2.Cells(10, "D") = sh1.Cells(i, "D")
sh2.Cells(10, "E") = sh1.Cells(i, "E")
sh2.Cells(10, "F") = sh1.Cells(i, "F")
sh2.Cells(10, "G") = sh1.Cells(i, "G")
sh2.Cells(10, "H") = sh1.Cells(i, "H")
sh2.Cells(10, "J") = sh1.Cells(i, "I")
'sh2.Range("a1:J34").PrintOut
Next i
End Sub

よろしくお願いいたします。

このQ&Aに関連する最新のQ&A

A 回答 (7件)

親の仇のようにお邪魔します。



>I列→J列にしたいのですが…

そうでしたね!ちゃんと最初の質問にもそうなっていました。
単純にそのままの列にコピー&ペーストしてしまっていました。

「印刷」SheetのI列には手を加えないようにしています。

Sub Sample4()
Dim i As Long, endRow1 As Long, endRow2 As Long, myArea1 As Range, myArea2 As Range
Dim wS1 As Worksheet, wS2 As Worksheet, wS3 As Worksheet
Set wS1 = Worksheets("DB")
Set wS2 = Worksheets("印刷")
Set wS3 = Worksheets("Sheet3")
endRow1 = wS1.Cells(Rows.Count, "A").End(xlUp).Row
Range(wS1.Cells(1, "A"), wS1.Cells(endRow1, "A")).AdvancedFilter Action:=xlFilterInPlace, unique:=True
wS1.Range("A:A").Copy wS3.Range("A1")
wS1.ShowAllData
For i = 2 To wS3.Cells(Rows.Count, "A").End(xlUp).Row
endRow2 = wS2.Cells(Rows.Count, "B").End(xlUp).Row
If endRow2 > 9 Then
Range(wS2.Cells(10, "B"), wS2.Cells(endRow2, "H")).ClearContents
Range(wS2.Cells(10, "J"), wS2.Cells(endRow2, "J")).ClearContents
End If
wS1.Range("A1").AutoFilter field:=1, Criteria1:=wS3.Cells(i, "A")
wS2.Range("B6") = wS3.Cells(i, "A")
Set myArea1 = Range(wS1.Cells(2, "B"), wS1.Cells(endRow1, "H")).SpecialCells(xlCellTypeVisible)
Set myArea2 = Range(wS1.Cells(2, "I"), wS1.Cells(endRow1, "I")).SpecialCells(xlCellTypeVisible)
myArea1.Copy
wS2.Activate
ActiveSheet.Range("B10").Select
Selection.PasteSpecial Paste:=xlPasteValues
myArea2.Copy
wS2.Activate
ActiveSheet.Range("J10").Select
Selection.PasteSpecial Paste:=xlPasteValues
endRow2 = wS2.Cells(Rows.Count, "B").End(xlUp).Row
Range(wS2.Cells(1, "A"), wS2.Cells(endRow2, "J")).PrintOut
Next i
wS1.AutoFilterMode = False
wS3.Cells.Clear
End Sub

※ 3度目の正直ならぬ、4度目ですが今度はどうでしょうか?

もっと簡単にFor~Nextでループさせた方が間違いなかったかもしれませんが、
敢えて、フィルタにこだわってみました。

今度はどうでしょうか?m(_ _)m
    • good
    • 0
この回答へのお礼

tom04さま
長々とおつきあい頂き本当にありがとうございます。
実際に印刷してまでしてみました。
全てが希望通りです!
感謝いたします!!

また何かありましたらよろしくお願いいたします。

お礼日時:2013/11/16 23:45

No.1・No.6 です。

本来、このサイトの目的は質問・回答ですので、コードの意味を少しだけ解説します。No.5 さんと No.6 の主な内容の比較です。


メインの転記の部分ですが、回答 No.5 では、オートフィルタ(Range.AutoFilter メソッド)により該当レコードのみ抽出し、表示される可視セル(xlCellTypeVisible のセル)をコピー・転記しています。No.6 では、フィルタオプション(Range.AdvancedFilter メソッド)という Excel の異なる機能により、コピーなしで転記しています。

どちらの方法でも転記の前に、「DB」シート A 列のユニークなデータ一覧を得る段階が必要です。No.5 では、こちらのほうをフィルタオプションで行っています。No.6 では、For・If・COUNTIF 関数を併用し、初出でないレコードにおいては処理なしとすることにより、達成しています。

Range.PrintOut メソッドを For ループの内側に入れてあるという点は、両者に共通していますね。

速度的には、No.6 では「約 5 万個のセルの挿入、切り取り、削除を何回か行うという処理」をこちらの判断で加えておいたという要素を除外すれば、どちらの方法でも大差ないかと思います。(ただし、きちんとした検証はしていません)


なお No.6 の文章には一点、コード以外の箇所に記述ミスがありました。すみません。正しくは、次のとおりです。片方は「2」ではなく「1」でした。

×
「下のコードでは、「印刷」シートの I 列に……約 5 万個の…… 2 回ずつ行っています。また、「印刷」シートの A 列に……約 5 万個の…… 2 回ずつ行っています。」


「下のコードでは、「印刷」シートの I 列に……約 5 万個の…… 2 回ずつ行っています。また、「印刷」シートの A 列に……約 5 万個の…… 1 回ずつ行っています。」
    • good
    • 0

No.1 です。




>Aの値が5000種あったとすると5000枚も印刷してしまうのです…。

どうすればいいかについては、No.1 で回答したつもりです。PrintOut メソッドの位置を考えます。プログラムでは、処理の順序というのがたいへん重要です。前後を入れ替えるだけで全く異なる結果になるという事例は、無数にあります。


「DB」シートの A 列のデータが何種類あるのか不明で、順番もバラバラなのだとすると、あまり易しいコードでの達成は難しいと思います。

下のコードでは、「印刷」シートの I 列に何が存在するのか不明なため、約 5 万個のセルを含む範囲の挿入、切り取り、削除を 2 回ずつ行っています。また、「印刷」シートの A 列に何が存在するのか不明なため、約 5 万個のセルを含む範囲の挿入、削除を 2 回ずつ行っています。

やはり PrintOut メソッドの位置に注意してください。「DB」シートの A 列で初出のデータが登場するたびに、「印刷」シートの必要な範囲をクリアし、新たに記入・印刷しています。したがってプロシージャの終了後に「印刷」シートに残っているデータは、「最後の初出」データのみとなります。

なお With ステートメントの導入により、「sh2」の繰り返しの記述を省略するようにしました。


Sub test01()
  Dim sh1 As Worksheet, sh2 As Worksheet, i As Long, v As Variant
  Set sh1 = Worksheets("DB")
  Set sh2 = Worksheets("印刷")
  Worksheets.Add before:=Worksheets(1)
  Worksheets(1).Range("a1").Value = "列1"
  sh1.Rows("2:2").Insert
  For i = 1 To 9
    sh1.Cells(2, i).Value = "列" & i
  Next i
  For i = 3 To sh1.Cells(Rows.Count, "a").End(xlUp).Row
    v = sh1.Cells(i, "a").Value
    If WorksheetFunction.CountIf(Range(sh1.Range("a2"), sh1.Cells(i, "a")), v) = 1 Then
      Worksheets(1).Range("a2").Value = v
      With sh2
        .Range("i10:i50000").Insert shift:=xlShiftToRight
        .Range("k10:k50000").Cut .Range("i10")
        .Range("k10:k50000").Delete shift:=xlShiftToLeft
        .Range("b10:i50000").ClearContents
        .Range("b6").Value = v
        .Range("b10:b50000").Insert shift:=xlShiftToRight
        sh1.Range("a2").Resize(sh1.Cells(Rows.Count, "a").End(xlUp).Row - 1, 9).AdvancedFilter _
          Action:=xlFilterCopy, criteriarange:=Worksheets(1).Range("a1:a2"), copytorange:=.Range("b10")
        .Range("b10:j10").Delete shift:=xlShiftUp
        .Range("b10:b50000").Delete shift:=xlShiftToLeft
        .Range("i10:i50000").Insert shift:=xlShiftToRight
        .Range("k10:k50000").Cut .Range("i10")
        .Range("k10:k50000").Delete shift:=xlShiftToLeft
        '.Range("a1:J34").PrintOut
      End With
    End If
  Next i
  sh1.Rows("2:2").Delete
  Application.DisplayAlerts = False
  Worksheets(1).Delete
  Application.DisplayAlerts = True
End Sub
    • good
    • 0

No.2・3です。



たびたびごめんなさい。
No.2の補足の
>(3)A列の値で多いもので500弱あるので、500行(20ページ)転記できるようにフォーマットを作成しました
を見逃していました。

すでにフォーマットができているというコトですので、コピー&ペーストは「値」で貼り付ける方が良いと思います。
今までのコードはすべて無視して↓のコードに変更してみてください。

Sub Sample3()
Dim i As Long, endRow1 As Long, endRow2 As Long, myArea As Range
Dim wS1 As Worksheet, wS2 As Worksheet, wS3 As Worksheet
Set wS1 = Worksheets("DB")
Set wS2 = Worksheets("印刷")
Set wS3 = Worksheets("Sheet3")
endRow1 = wS1.Cells(Rows.Count, "A").End(xlUp).Row
Range(wS1.Cells(1, "A"), wS1.Cells(endRow1, "A")).AdvancedFilter Action:=xlFilterInPlace, unique:=True
wS1.Range("A:A").Copy wS3.Range("A1")
wS1.ShowAllData
For i = 2 To wS3.Cells(Rows.Count, "A").End(xlUp).Row
endRow2 = wS2.Cells(Rows.Count, "B").End(xlUp).Row
If endRow2 > 9 Then
Range(wS2.Cells(10, "B"), wS2.Cells(endRow2, "J")).ClearContents
End If
wS1.Range("A1").AutoFilter field:=1, Criteria1:=wS3.Cells(i, "A")
wS2.Range("B6") = wS3.Cells(i, "A")
Range(wS1.Cells(2, "B"), wS1.Cells(endRow1, "J")).SpecialCells(xlCellTypeVisible).Copy
wS2.Activate
ActiveSheet.Range("B10").Select
Selection.PasteSpecial Paste:=xlPasteValues
endRow2 = wS2.Cells(Rows.Count, "B").End(xlUp).Row
Set myArea = Range(wS2.Cells(1, "A"), wS2.Cells(endRow2, "J"))
myArea.PrintOut
Next i
wS1.AutoFilterMode = False
wS3.Cells.Clear
End Sub

何度も失礼しました。m(_ _)m

この回答への補足

度々お世話になります。
実行してみました。
後ひとつだけお願いします!
DBのI列の値が印刷用のI列に転記されてしまいます。
I列→J列にしたいのですが…
よろしくお願いいたします。

補足日時:2013/11/16 22:15
    • good
    • 0

No.2です。



(1)罫線が消えてしまった
(2)フォントサイズが11から9になってしまった
(3)A列の値で多いもので500弱あるので、500行(20ページ)転記できるようにフォーマットを作成しました。
A~J列、1行目から34行目までで1枚です。
なのでたとえ転記された行が1行でも20ページ印刷してしまうのです…
印刷範囲を転記された最終行を含めたページまでとすることは可能でしょうか?

上記の補足の
(1)・(2)に関して
前回のコードは「DB」Sheetにフィルタをかけて、B列最終行までをそのまま「印刷」Sheetにコピー&ペーストしていますので、
「DB」Sheetの書式がそのままコピーされます。
もしかして、「DB]Sheetのフォントサイズが 9Pt で罫線もないのでしょうか?

これに関しては「印刷」SheetのB列最終行までのフォントサイズを11Ptに
データがあるまで「格子」罫線にしてみました。

(3)に関して
もしかして、A列または他の列にデータが入っているのでしょうか?
それとも最初から罫線だけがかなり設定してあるのでしょうか?
そうであればデータがあるだけ(空白でも罫線がある行まで)印刷されてしまいますので
「印刷」SheetのB列最終行までを「印刷範囲」としてみました。

もう一度コードを載せてみます。

Sub Sample2()
Dim i As Long, endRow1 As Long, endRow2 As Long, myArea As Range
Dim wS1 As Worksheet, wS2 As Worksheet, wS3 As Worksheet
Set wS1 = Worksheets("DB")
Set wS2 = Worksheets("印刷")
Set wS3 = Worksheets("Sheet3")
endRow1 = wS1.Cells(Rows.Count, "A").End(xlUp).Row
Range(wS1.Cells(1, "A"), wS1.Cells(endRow1, "A")).AdvancedFilter Action:=xlFilterInPlace, unique:=True
wS1.Range("A:A").Copy wS3.Range("A1")
wS1.ShowAllData
For i = 2 To wS3.Cells(Rows.Count, "A").End(xlUp).Row
endRow2 = wS2.Cells(Rows.Count, "B").End(xlUp).Row
If endRow2 > 9 Then
Range(wS2.Cells(10, "B"), wS2.Cells(endRow2, "J")).Clear '←書式も消してみました
End If
wS1.Range("A1").AutoFilter field:=1, Criteria1:=wS3.Cells(i, "A")
wS2.Range("B6") = wS3.Cells(i, "A")
Range(wS1.Cells(2, "B"), wS1.Cells(endRow1, "J")).SpecialCells(xlCellTypeVisible).Copy wS2.Range("B10")
endRow2 = wS2.Cells(Rows.Count, "B").End(xlUp).Row
With wS2.Range("B6")
.Font.Size = 11
.Borders.LineStyle = xlContinuous
End With
With Range("B10").CurrentRegion
.Font.Size = 11
.Borders.LineStyle = xlContinuous
End With
Set myArea = Range(wS2.Cells(1, "A"), wS2.Cells(endRow2, "J"))
myArea.PrintOut
Next i
wS1.AutoFilterMode = False
wS3.Cells.Clear
End Sub

今度はうまくいけばよいのですが・・・m(_ _)m

この回答への補足

tom04さま、早々のご教示ありがとうございます。
DBの書式はおっしゃる通りフォントサイズが9で罫線はありません。
元の書式のせいだったのですね…すみませんでした。
印刷用の方にインデントや赤の太枠など色々と設定しており、
500行分罫線を引きA列にNo.を入力しておりました。

新しいコードで実行したところ、
B6セルに罫線がひかれてしまう、
インデントの設定が消えてしまう、
赤色の太枠が消えてしまう、
表内の罫線(点線)が消えてしまう…などのことがありました。

印刷用のシートの書式設定を崩したくない場合、
DBの書式を印刷用と同じようにして、
最初のコードに「印刷」SheetのB列最終行までを「印刷範囲」というコードを足した方がいいのでしょうか?

Set myArea = Range(wS2.Cells(1, "A"), wS2.Cells(endRow2, "J"))
myArea.PrintOut
↑最初のコードにこの部分を足すのでしょうか?

度々申し訳ありませんが、もう少しおつきあいください。
よろしくお願いいたします。

補足日時:2013/11/16 21:30
    • good
    • 0

こんばんは!


横からお邪魔します。

こういうコトでしょうかね?
尚、Sheet3を作業用のSheetとして使用していますので、Sheet3は使用していない状態でマクロを実行してみてください。

標準モジュールです。

Sub Sample1()
Dim i As Long, endRow1 As Long, endRow2 As Long
Dim wS1 As Worksheet, wS2 As Worksheet, wS3 As Worksheet
Set wS1 = Worksheets("DB")
Set wS2 = Worksheets("印刷")
Set wS3 = Worksheets("Sheet3")
endRow1 = wS1.Cells(Rows.Count, "A").End(xlUp).Row
Range(wS1.Cells(1, "A"), wS1.Cells(endRow1, "A")).AdvancedFilter Action:=xlFilterInPlace, unique:=True
wS1.Range("A:A").Copy wS3.Range("A1")
wS1.ShowAllData
For i = 2 To wS3.Cells(Rows.Count, "A").End(xlUp).Row
endRow2 = wS2.Cells(Rows.Count, "B").End(xlUp).Row
If endRow2 > 9 Then
Range(wS2.Cells(10, "B"), wS2.Cells(endRow2, "J")).ClearContents
End If
wS1.Range("A1").AutoFilter field:=1, Criteria1:=wS3.Cells(i, "A")
wS2.Range("B6") = wS3.Cells(i, "A")
Range(wS1.Cells(2, "B"), wS1.Cells(endRow1, "J")).SpecialCells(xlCellTypeVisible).Copy wS2.Range("B10")
wS2.PrintOut
Next i
wS1.AutoFilterMode = False
wS3.Cells.Clear
End Sub

※ 外していたらごめんなさいね。m(_ _)m

この回答への補足

tom04さま、ありがとうございます。
早速実行してみました。
希望通りの転記となりました!素晴らしいです!

後出しで申し訳ありませんが、
困ったことがあります。

(1)罫線が消えてしまった

(2)フォントサイズが11から9になってしまった

(3)A列の値で多いもので500弱あるので、500行(20ページ)転記できるようにフォーマットを作成しました。

A~J列、1行目から34行目までで1枚です。

なのでたとえ転記された行が1行でも20ページ印刷してしまうのです…

印刷範囲を転記された最終行を含めたページまでとすることは可能でしょうか?

$1:$9は印刷タイトルに使用しています。

申し訳ありませんが、よろしくお願いいたします。

補足日時:2013/11/16 19:34
    • good
    • 0

変数 i の宣言は、Long 型としました。

変数 d は、整理しました。他で使う用事があるなど必要な場合は、復活させてください。Range.PrintOut メソッドは、行の位置を入れ替えてあります。


Sub test01()
  Dim i As Long
  Dim sh1 As Worksheet
  Dim sh2 As Worksheet
  Set sh1 = Worksheets("DB")
  Set sh2 = Worksheets("印刷")
  For i = 2 To sh1.Range("A65536").End(xlUp).Row
    sh2.Cells(i + 4, "A").Value = sh1.Cells(i, "A").Value
    Range(sh2.Cells(i + 8, "B"), sh2.Cells(i + 8, "H")).Value = Range(sh1.Cells(i, "B"), sh1.Cells(i, "H")).Value
    sh2.Cells(i + 8, "J").Value = sh1.Cells(i, "I").Value
  Next i
  'sh2.Range("a1:J34").PrintOut
End Sub

この回答への補足

MarcoRossiItalyさん、ありがとうございます。
早速やってみたのですが、2点ご報告です。
(1)一枚のシートにDBのA列の値がすべて転記されてしまいます。
(2)DBのA2の値はB6セルに転記させたいのですが、A列すべてに転記されてしまいます。

こちらの説明不足で申し訳ありません。

DBシート
A列  B列  C列・・・・I列
200  201
300  304
200  201
300  302
200  203

とした時、
印刷シート
B6 200

    B列・・・J列
10行目 201
11行目 201
12行目 203

これで印刷

続いて
印刷シート
B6 300

    B列・・・J列
10行目 304
11行目 302

これで印刷。

この繰り返し。

といったようにDBのA列に出てくる値ごとにまとめて印刷に転記、
印刷→A列の次の値、これをDBの最終行まで行いたいのです。

印刷シートのA列にDBのA列すべての値が転記されてしまっており、
修正の仕方を今いろいろ考えていじってはいるのですが…。

こちらの貼付したコードではDBのA列の値ひとつに対して、
印刷シートにひとつ転記して印刷を開始してしまう。
→Aの値が5000種あったとすると5000枚も印刷してしまうのです…。

申し訳ありませんが、再度ご教示いただけないでしょうか?
よろしくお願いいたします。

補足日時:2013/11/16 17:43
    • good
    • 0

このQ&Aに関連する人気のQ&A

お探しのQ&Aが見つからない時は、教えて!gooで質問しましょう!

このQ&Aを見た人はこんなQ&Aも見ています

このQ&Aを見た人が検索しているワード

このQ&Aと関連する良く見られている質問

Qエクセル入力で項目別にシートに振り分ける方法を教えてください!

エクセルでの入力の時に
シート1では全ての営業所をひとまとめにして入力
シート2以降では営業所別にシートに振り分ける方法がわかりません。

シート1(入力するシート)
1 営業所名  支出金額  項目
2 群馬支部  11980  雑費
3 長野支部  12080  交通費
4 群馬支部  19800  接待交際費
5 新潟支部  19800  接待交際費

シート2(群馬支部)
1 営業所名 支出金額 項目
2 群馬支部 11980 雑費
4 群馬支部 19800 接待交際費

入力する場所はシート1のみで
シート2、3は営業部ごとの項目になっていて
シート1に入力すると自動で各シートに
振り分けられるようにしたいのです。

これを解決できる方法とは、どのような方法があり
そしてどうやれば出来るのでしょうか?

お時間あるときにご返答頂けると嬉しいです。
どうぞよろしくお願い致します。

Aベストアンサー

関数のみで行う場合です。

シート1(入力するシート)
 A  B       C       D
1 No. 営業所名  支出金額  項目
2 1 群馬支部   11980    雑費
3 2 長野支部   12080    交通費
4 3 群馬支部   19800    接待交際費
5 4 新潟支部   19800    接待交際費

VLOOKUP関数で処理するのでA列にNo.を入れてください。
ちなみにA2以降のA列に
  =ROW()-MATCH("No.",A:A,0)
と入れると並べ替えをしても行番号が変わりません。

シート2(群馬支部)
  A B        C      D       E
1   営業所名 データ数 総データ数
2   群馬支部   2      4
3 
4                           行番号
5 No. 営業所名 支出金額 項目       0
6  1  群馬支部  11980   雑費       1
7  2  群馬支部  19800   接待交際費  3
8  3                          #N/A

各セルに次の関数を入れます。
B2:営業所名
   ここをリスト化すると1枚のシートで全営業所が計算できます。
C2:=COUNTIF(Sheet1!B:B,A2)
   群馬支部のデータ数を求める
D2:=MAX(Sheet1!A:A) or =COUNTA(Sheet1!B:B)-1
   総データ数を求める
D5:0
D6:=MATCH($A$2,INDIRECT("Sheet1!$B$"&TEXT(E5+2,"0")&":B"&TEXT($C$2+1,"0")),0)+E5
   非常に面倒な式ですが、シート1における営業所名の出現行を
   MATCH関数で出しています。単純に組むと一番始めしか出て来な
   いので次の行では前行で見つけたシート1での出現行の次から
   検査する必要があります。
   そのためINDIRECT関数で可変する範囲を設定しています。
A6:連番(シート1と同じ)
B6:=IF(ISERROR($E6),"",VLOOKUP($E6,Sheet1!$A:$D,2,FALSE))
   VLOOKUP関数で必要データを取り出します。
   データがなくなるとE列の行番号がエラーになるので、そこは
   表示しない(空白)ためのif文を加えてあります。
   後は必要行コピーすれば完成です。

 

関数のみで行う場合です。

シート1(入力するシート)
 A  B       C       D
1 No. 営業所名  支出金額  項目
2 1 群馬支部   11980    雑費
3 2 長野支部   12080    交通費
4 3 群馬支部   19800    接待交際費
5 4 新潟支部   19800    接待交際費

VLOOKUP関数で処理するのでA列にNo.を入れてください。
ちなみにA2以降のA列に
  =ROW()-MATCH("No.",A:A,0)
と入れると並べ替えをしても行番号が変わりません。

シート2(...続きを読む

QエクセルVBA:表の内容を担当者別に振り分けたい

よろしくお願いいたします。
VBA初心者です。よろしくご指導をお願いいたします。
安易に教えてgooで質問することにお叱りをいただくこともあり、
VBAの本も数冊買って勉強をはじめ、格闘していますが、手に負えません。どうか助けてください。

  A     B   C   D   E    F   g
 担当者  日付 商品 規格 数量  単価 備考
1山田太郎  ○  △  ■   ◎  ◇   ▼
2鈴木次郎  ■  ○  ▼   ■  ○   ○
3佐藤三郎  △  ■  ○   ◎  ◎   ■
4山田太郎  ▼  ■  ◎   ■  ○   ▼
5山田太郎  ◇  ○  ◎   ◇  ◆   ◎
6鈴木次郎  ◆  ◎  ◇   ◎  ◇   ◇

というような入力シートの表があり、レコードは1000以上、下にたくさん続きます。
○や▼には実際には数値や商品名、短文などが入ります。

担当者は、50名、そこで「山田太郎」をはじめ、担当者氏名の名前の50のワークシートを作成しています。

そこで、次のようなVBAを書きたいのです。
VBAを実行すると、

シート別に入力表のデータが振り分けられて、
「山田太郎」に
 A  B   C   D   E    F   g
1  日付 商品 規格 数量  単価  備考
2  ○  △  ■   ◎  ◇    ▼
3  ▼  ■  ◎   ■  ○    ▼
4  ◇  ○  ◎   ◇  ◆    ◎
と入力シートに入力されたデータが50名のシートに振り分けられるものです。
どうか、よろしくご指導お願いいたします。

よろしくお願いいたします。
VBA初心者です。よろしくご指導をお願いいたします。
安易に教えてgooで質問することにお叱りをいただくこともあり、
VBAの本も数冊買って勉強をはじめ、格闘していますが、手に負えません。どうか助けてください。

  A     B   C   D   E    F   g
 担当者  日付 商品 規格 数量  単価 備考
1山田太郎  ○  △  ■   ◎  ◇   ▼
2鈴木次郎  ■  ○  ▼   ■  ○   ○
3佐藤三郎  △  ■  ○   ◎  ◎   ...続きを読む

Aベストアンサー

No.2です。大変失礼しました。十分な確認ができてないまま投稿してしまいました。

TmpWS.Columns("A:A").Sort Key1:=Range("A2"), Header:=xlYes
の行を
TmpWS.Columns("A:G").Sort Key1:=Range("A2"), Header:=xlYes
に変更してください。やり直すときは、作成された担当者別のシートは削除してからでお願いします。

QEXCEL データの各シートへの振り分け

エクセルの1枚目のシートをデータシートとして、各行に入力していきます。
各行の第1列の数字や言葉に基づいて、2枚目以降のシートに順にコピーさせる方法があるでしょうか

具体的には1枚目のシートはデータシートとして
部門 氏名 住所 
人事 田村 東京
総務 太田 京都
人事 山田 大阪

2枚目のシートの名前は「人事」3枚目は「総務」で各シートに行ごとコピーさせたいのです

マクロはよくわからないのと最初に開くときに面倒なので、なるべく関数で処理する方法を教えてください。

Aベストアンサー

質問者さんの意図とは少し違いますが、次のような簡単な方法があります。適当な回答がなければ、ご検討ください。

(1)2枚目以降のシートで =sheet1!A1 などとして、1枚目のシートの該当するセル範囲(これから入力される可能性のある部分を含む)のデータをすべて取り込む
(2)オートフィルタで望みの行だけ表示する
(3)1枚目のデータが増えたり変更されたりしたら、フィルタの「再適用」(2007ではボタンあり)をして最新の結果を得る

(2007とその97-2003互換モードで確認しました。)

QExel VBA 別ブックから該当データを検索し、必要なデータを取得する方法について

部品表というブックがあります
A列に商品名、B列に商品番号が入力してあります。C列のコードは未入力です。
A列     B列     C列      
商品名  商品番号  コード
モータ  U-1325-L  
ホルダ  R-134256

また、コード一覧表という別のブックには、A列に商品番号と、B列にコードが、何千件も入力されています。

やりたいことは
部品表のC列のコード欄に、コード一覧表ブックから商品番号と一致するコードを貼り付けしたいのです。

部品表は、何百種類もありますので、関数ではなく、マクロで処理を希望します。

自分では、部品表の商品番号をコピーして、コード一覧表で検索し、検索結果の右隣のセル(B列のコード)の値を部品表のC列に貼り付ければよいかと思い、書いてみたんですが…

Sub 別ブックから貼り付ける()
  Dim 検索する As Long
Windows("部品表.xls").Activate
検索する = cells(i,2).Value
Windows("コード一覧表.xls").Activate
ActiveWindow.SmallScroll Down:=-3
Selection.AutoFilter Field:=3, Criteria1:="=検索する", Operator:= xlAnd

と、してみたものの、検索しても、その検索結果の隣のセルのコードをどうやって取得すればいいのかが、わかりませんでした。

基本事項は本で学びましたが、呪文のようなコードはよく理解できません。懸命にネットで検索して、訳して理解する努力をしてはいますが。

どうぞよろしくお願いします。

部品表というブックがあります
A列に商品名、B列に商品番号が入力してあります。C列のコードは未入力です。
A列     B列     C列      
商品名  商品番号  コード
モータ  U-1325-L  
ホルダ  R-134256

また、コード一覧表という別のブックには、A列に商品番号と、B列にコードが、何千件も入力されています。

やりたいことは
部品表のC列のコード欄に、コード一覧表ブックから商品番号と一致するコードを貼り付けしたいのです。

部品表は、何百種類もありますので、関数...続きを読む

Aベストアンサー

こんにちは。
とりあえず実用性も踏まえました。
メインの動作はワークシート関数のVLOOKUPをVBA上で使用していますので理解はしやすいかと思います。
また、質問文から察するに「部品表.xls」と「コード一覧表.xls」の両方を開いて処理されていますが「コード一覧表.xls」はプログラム内で開いて閉じているので実行するときは「コード一覧表.xls」は閉じて置いてください。
Option Explicit
Sub Sample()
 Application.ScreenUpdating = False
 Dim I As Long
 Dim xlBook
 Set xlBook = Workbooks.Open("C:\★★\コード一覧表.xls") '★要変更★
 I = 2
 Do While Range("A" & I).Value <> ""
  ThisWorkbook.Worksheets("Sheet1").Range("C" & I).Value = Application.VLookup(ThisWorkbook.Worksheets("Sheet1").Range("B" & I).Value, xlBook.Worksheets("Sheet1").Range("A2:B65535"), 2, 0)
  I = I + 1
 Loop
 xlBook.Close
 Application.ScreenUpdating = True
 MsgBox ("完了")
End Sub

こんにちは。
とりあえず実用性も踏まえました。
メインの動作はワークシート関数のVLOOKUPをVBA上で使用していますので理解はしやすいかと思います。
また、質問文から察するに「部品表.xls」と「コード一覧表.xls」の両方を開いて処理されていますが「コード一覧表.xls」はプログラム内で開いて閉じているので実行するときは「コード一覧表.xls」は閉じて置いてください。
Option Explicit
Sub Sample()
 Application.ScreenUpdating = False
 Dim I As Long
 Dim xlBook
 Set xlBook = Workbooks....続きを読む

Q複数条件が一致で別シートに転記【エクセルVBA】

エクセルでセルの条件が複数一致したら別シートに転記される方法をお教えください。
シートを2枚用意して、配達日ごとに一覧化したいのです。
事前に用意したシート(配達表)の“配達”と“配達時間”が一致したら
その方の名前と注文個数を右側に反映したいのですが・・・

注文データが多すぎて困っています。
宜しくお願いします。

■シート名:注文データ
   A    B    C    D    E
------------------------------------------------
1 しめい  対応   配達日   時間   個数
------------------------------------------------
2 たけだ  配達  6/20(月) 13:00  2個
3 みうら  配達  6/18(土) 14:00  4個
4 らもす  郵送  6/20(月)  ―   5個
5 いはら  配達  6/20(月) 14:30  8個
6 かつや  配達  6/20(月) 15:00  6個
7 みうら  郵送  6/20(月)  ―   4個

■シート名:配達表
    A     B    C
------------------------------------
1  配達   6/20(月)
------------------------------------
2  12:00
3  12:30
4  13:00
5  13:30
6  14:30
7  15:00
8  15:30
9  16:00

マクロを実行すると・・・
↓↓↓↓↓↓↓↓↓↓↓↓↓↓↓↓↓↓↓

■シート名:配達表
    A     B    C
------------------------------------
1  配達   6/20(月)
------------------------------------
2  12:00 
3  12:30
4  13:00    たけだ   2個
5  13:30
6  14:00    みうら   4個
6  14:30   いはら   8個
7  15:00   かつや   6個
8  15:30
9  16:00

エクセルでセルの条件が複数一致したら別シートに転記される方法をお教えください。
シートを2枚用意して、配達日ごとに一覧化したいのです。
事前に用意したシート(配達表)の“配達”と“配達時間”が一致したら
その方の名前と注文個数を右側に反映したいのですが・・・

注文データが多すぎて困っています。
宜しくお願いします。

■シート名:注文データ
   A    B    C    D    E
------------------------------------------------
1 しめい  対応   配達日   時間   個数
-...続きを読む

Aベストアンサー

こういうのは「複数条件による抜き出し問題」だ。
関数で出来ればおなじみのやり方で良いのだが、既に出ているように式が長く複雑で、初心者には何をやって居るかわからない式になる。毎度週に数回このタイプの質問が出て、同じようなタイプの答えになる。Googleででも「imogasi方式」で照会すれば、過去の沢山の例と回答(そのタイプも)が出てくる。
ーー
まず初心者や急ぐ場合はデーターフィルターフィルタオプションの設定で済ませられないか勉強すべきだ。
ーー
本来、こういう仕事の関連のエクセル表は、VBAを勉強してそれを使うべきと思う(既に回答も出ているようだ)
関数で抜き出し問題や表の組み換えは、VBAで無いと、天下りの長い式をコピペで使うだけになる。
ーー
私が紹介している「imogasi方式」では、Sheet2に時刻の所定の行に出す問題なので複雑になりすぎる。
ーー
VBAでやってみる。
例データ
しめい対応配達日時間個数
たけだ配達6月20日13:002個
みうら配達6月18日14:004個
らもす郵送6月20日ーー5個
いはら配達6月20日14:308個
かつや配達6月20日15:006個
みうら郵送6月20日ーー4個
(注意)
「ーー」セルは空白とする
「月日」列は、エクセルの年月日を入れておくこと(日付シリアル値(わかりますか)) 文字列では不可
6/20(月) の様な表示は、表示形式の設定でやること(エクセルの常識)  m/d(aaa)
時間の列も時刻シリアル値で入れてあるとする。文字列では不可
ーー
コード
標準モジュールに
Sub test01()
Dim sh1, sh2
Set sh1 = Worksheets("Sheet1")
Set sh2 = Worksheets("Sheet2")
d = sh1.Range("A65536").End(xlUp).Row
On Error Resume Next
For i = 2 To d
'--条件をかけて選別
If sh1.Cells(i, "B") = "配達" And sh1.Cells(i, "C") = sh2.Range("B1") And _
sh1.Cells(i, "D") <> "" Then
t = sh1.Cells(i, "D")
'---Sheet2で時刻行を探す
For r = 2 To 30
If sh1.Cells(i, "D") = sh2.Cells(r, "A") Then Exit For
Next r
'--該当行の値をSheet2の時刻該当行セット
Sheet2.Cells(r, "B") = sh1.Cells(i, "A")
Sheet2.Cells(r, "C") = sh1.Cells(i, "E")
End If
Next i
End Sub
ーー
実行結果
Sheet2
配達6月20日
12:00
12:30
13:00たけだ2個
13:30
14:00
14:30いはら8個
15:00かつや6個
15:30
16:00
・・・・・・

こういうのは「複数条件による抜き出し問題」だ。
関数で出来ればおなじみのやり方で良いのだが、既に出ているように式が長く複雑で、初心者には何をやって居るかわからない式になる。毎度週に数回このタイプの質問が出て、同じようなタイプの答えになる。Googleででも「imogasi方式」で照会すれば、過去の沢山の例と回答(そのタイプも)が出てくる。
ーー
まず初心者や急ぐ場合はデーターフィルターフィルタオプションの設定で済ませられないか勉強すべきだ。
ーー
本来、こういう仕事の関連のエクセル表...続きを読む

Qエクセルの表を複数枚印刷したときに連番をつけたい

エクセルの1枚の表を100枚印刷し、その表のシート内(AW3)に連番を打ちたいのですが、なにか簡単な方法はありますか?
今までは印刷を100枚して、ナンバーリング(ハンコ)で連番を打っていましたが、ちょっと面倒なんです。
マクロを使ったことのない初心者ですが、何かよい方法はありませんか?よろしくお願いいたします。

Aベストアンサー

#02です。
開始番号、終了番号を指定する場合はこんなマクロです。
ただし開始、終了ともに正の数でないと印刷は行いません。

Sub NumberPrint()
Dim idx As Integer
Dim frmPage, toPage
 frmPage = Application.InputBox("連番を挿入して印刷します" & Chr(13) _
     & "開始番号を入力してください", Type:=1)
 toPage = Application.InputBox("終了番号を入力してください", Type:=1)
 If frmPage > 0 And toPage >= frmPage Then
  For idx = frmPage To toPage
   Range("AW3").Value = idx
   ActiveSheet.PrintOut
  Next idx
 Else
  MsgBox "開始番号、終了番号が不適切です。印刷は行いません"
 End If
End Sub

#02です。
開始番号、終了番号を指定する場合はこんなマクロです。
ただし開始、終了ともに正の数でないと印刷は行いません。

Sub NumberPrint()
Dim idx As Integer
Dim frmPage, toPage
 frmPage = Application.InputBox("連番を挿入して印刷します" & Chr(13) _
     & "開始番号を入力してください", Type:=1)
 toPage = Application.InputBox("終了番号を入力してください", Type:=1)
 If frmPage > 0 And toPage >= frmPage Then
  For idx = frmPage To toPage
   Range("AW3...続きを読む

Qエクセルで、条件に一致した行を別のセルに抜き出す方法

エクセルで、指定した条件に一致するセルを含む行をすべて抜き出す方法が知りたいです。

たとえば、

<A列> <B列> <C列>
7/1 りんご 100円
7/2 ぶどう 200円
7/2 すいか 300円
7/3 みかん 100円

このような表があって、100円を含む行をそのままの形で、
別のセル(同じシート内)に抜き出したいのですが。

7/1 りんご 100円
7/3 みかん 100円

抽出するだけならオートフィルターでもできますが、
抽出結果を自動的に、別の場所に、常に表示させておきたいのです。

初歩的な質問だと思いますが、検索しても分からなかったので、よろしくお願いします。

Aベストアンサー

同じ質問が結構よく出てますが、そんなに初歩的でもありません
別シートのA1セルに「100円」と入力し、そのシートの任意のセルに以下の式を貼り付けて下さい。後は、下方向、右方向にコピー。
日付のセル書式は「日付」形式に再設定してください

=IF(COUNTIF(Sheet1!$C:$C,$A$1)>=ROW(A1),INDEX(Sheet1!A:A,LARGE(INDEX((Sheet1!$C$1:$C$500=$A$1)*ROW(Sheet1!$C$1:$C$500),),COUNTIF(Sheet1!$C:$C,$A$1)-ROW(A1)+1)),"")

データ範囲は500行までとしていますが、必要に応じて変更して下さい

Qエクセルの1シートを項目別に別シートへ分ける方法

エクセル2010で1シートのデータを項目別に別シートへ自動的に分割する方法で困っています。
検索するとマクロを使うと書いていますが、マクロはほとんど使ったことが無いのもあって、わかりませんでした。

シート1
A列(日付8ケタ+商品番号6ケタ) B列(売上額)
20130515000004           300
20130515000006           100
20130518000004           300
20130519000001           500
20130519000004           300
・・・                   ・・・
をA列の日付部分上8ケタを使って日別にシートを分け、
シート名をuriage20130515(uriageと日付8ケタ)という名前にしシート名+CSV形式で保存したいです。

シート2 シート名:uriage20130515
A列         B列
20130515000004 300
20130515000006 100

シート3 シート名:uriage20130518
A列         B列
20130518000004 300

シート4 シート名:uriage20130519
A列         B列
20130519000001 500
20130519000004 300

このように自動で別シートに分割した上で、シート名CSV形式で保存まで自動でできるとありがたいです。

自動化できるならシートを分割するマクロ、シート名でCSV保存するマクロが一つのマクロになっていても、分かれていてもOKです。

このようなことはできますか?

よろしくお願いします。

エクセル2010で1シートのデータを項目別に別シートへ自動的に分割する方法で困っています。
検索するとマクロを使うと書いていますが、マクロはほとんど使ったことが無いのもあって、わかりませんでした。

シート1
A列(日付8ケタ+商品番号6ケタ) B列(売上額)
20130515000004           300
20130515000006           100
20130518000004           300
20130519000001           500
20130519000004           300
・・・           ...続きを読む

Aベストアンサー

手順:
元データのブックを一度保存して開き直す
ALT+F11を押す
現れた画面で挿入メニューから標準モジュールを挿入する
現れたシートに下記をコピー貼り付ける

sub macro1()
 dim myPath as string
 dim myFile as string
 dim h as range
 dim s as string
 dim w as worksheet

 mypath = thisworkbook.path & "\"
 on error resume next
 kill mypath & "*.csv"
 application.displayalerts = false
 for each w in worksheets
  if w.name <> activesheet.name then w.delete
 next
 application.displayalerts = true
 on error goto errhandle

 for each h in range("A1:A" & range("A65536").end(xlup).row)
 if isnumeric(h.value) then
  s = left(h.value, 8)

 ’CSVに書き出し
  open mypath & "uriage" & s & ".csv" for append as #1
  print #1, h.value & "," & h.offset(0,1).value
  close #1

 ’シートに書き出し
  h.entirerow.copy worksheets(s).range("A65536").end(xlup).offset(1)

 end if
 next

 for each w in worksheets
  w.columns("A:B").autofit
 next
 exit sub

errhandle:
 worksheets.add after:=worksheets(worksheets.count)
 activesheet.name = s
 range("A1:B1") = array("date", "value")
 resume
end sub


ファイルメニューから終了してエクセルに戻る
ALT+F8を押しマクロを実行すると,CSVを書き出す。



#「CSVを書き出す」のが目的で「別シートに振り分ける」こと自体に目的はないと思いましたが,まぁご相談なのでシートに書き出しも追加しました。。。と思って書き足してったら無駄に長いマクロになっちゃいました。あんまりイミなかったです。

手順:
元データのブックを一度保存して開き直す
ALT+F11を押す
現れた画面で挿入メニューから標準モジュールを挿入する
現れたシートに下記をコピー貼り付ける

sub macro1()
 dim myPath as string
 dim myFile as string
 dim h as range
 dim s as string
 dim w as worksheet

 mypath = thisworkbook.path & "\"
 on error resume next
 kill mypath & "*.csv"
 application.displayalerts = false
 for each w in worksheets
  if w.name <> activesheet.name then w.delete
 next
 a...続きを読む

QExcelVBAを使って、値がある場合は作業を繰り返し実行するプログラムを作成したい。

以下のようなプログラムをVBAで作成したいと考えています。

A1のセルに値があれば、その値をB1に返す。
次にA2のセルに値があれば、その値をB2に返す。
A行に値がある一番下のセルまで同じようなことをさせたいと考えています。

VBAは初心者です。
どなかた宜しくお願い致します。

Aベストアンサー

#2さんと似たものですが・・・・参考にしてください。

Sub test001()
Dim i As Long
i = 1
Do While Cells(i, 1) <> ""
Cells(i, 2) = Cells(i, 1)
i = i + 1
Loop
End Sub

Qエクセル:シート名を手入力でなく、セル「A1」の文字を出したい。

いつもお世話になります。
エクセルのシート名についての質問です。
いつもはシート名を変えるとき、シートタブの上を右クリックして「変更」しています。

◆そこで、
(1) セル「A1」に入力されてある文字を自動で出す
(2) もしくはマクロボタンを押すと「A1」に入力されてあるものが「シート名」として変わる

というようにしたいのですが、その方法について教えてください。よろしくお願いいたします。

Aベストアンサー

こんにちは。


(1)の場合は、下記のコードを ThisWorkbook に記述してください。
どのワークシートでも機能します。

Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range)
If Target.Address = "$A$1" Then Sh.Name = Target.Range("A1").Value
End Sub


(2)場合は、下記のコードを標準モジュールに記述しボタンにマクロ登録してください。
(すべてのシートにボタンを貼り付けるのは面倒でしょうから、ツールバーにボタンとして追加すると良いと思います。)

Public Sub SheetName()
ActiveSheet.Name = Range("A1").Value
End Sub


このQ&Aを見た人がよく見るQ&A

人気Q&Aランキング

おすすめ情報