[[20090407134813]]　『抽出マクロ』（はとむぎ）　ページの最後に飛ぶ

『抽出マクロ』（はとむぎ）

　　　　　Sheet1

	A	B	C	D	E	F	G	H
1								
2								
3	○運送		沖縄県		2009/4/7			
4	1111番		大型					
5								
6	◆運送		福岡県		2009/4/6			
7	2222番		小型					
8								
9	×運送		宮崎県		2009/4/5			
10	3333番		小型

	Sheet2

	A	B	C	D	E	F	G	H
1	会社名	番号	住所	日付						
2	○運送	1111番	沖縄県	2009/4/7						
3	◆運送	2222番	福岡県	2009/4/6						
4	×運送	3333番	宮崎県	2009/4/5						
5

上記の様な表（Sheet1）が1000行にも渡って毎月作成されます。あまりにも見難いので必要なもののみ抜き出して（Sheet2）の様に表示したいのですがマクロを使ってできますでしょうか？自分のマクロ知識は自動記録程度であとは殆どわかりません。出来れば解説付きで教えて頂きたいです。宜しくお願いします。

 こんな感じでしょうか？

 Sub test()
 Dim myAreas As Areas, i As Long
 With Sheets("sheet1").Columns(1)
     On Error Resume Next
     Set myAreas = .SpecialCells(2).Areas
     On Error GoTo 0
     If myAreas Is Nothing Then Exit Sub
     For i = 1 To myAreas.Count
         Sheets("sheet2").Range("a" & Rows.Count).End(xlUp)(2) _
         .Resize(, 4).Value = Array(myAreas(i).Cells(1).Value, _
         myAreas(i).Cells(2).Value, myAreas(i).Cells(1).Offset(, 2).Value, _
         myAreas(i).Cells(1).Offset(, 4).Value)
     Next
 End With
 End Sub
 (seiya)

seiyaさん、ありがとうございます。まさにこれです！！

ただ、内容は全く分からないのですが・・・皆さんどうやって勉強されてるのでしょうか？
解説してはもらえないですか？面倒とは思われますがお願いします！！

（はとむぎ）

 はとむぎさん
 VBAに関してはどの程度の知識をお持ちですか？
 (seiya)

 ＞自分のマクロ知識は自動記録程度であとは殆どわかりません。
 でしたら、

 １．シートをコピー
 ２．D列を削除
 ３．A列をコピーして、B列に貼り付け
 ４．B1セルを削除（上方向へシフト）
 ５．１行目に見出しを入力
 ６．オートフィルタを設定
 ７．日付列（D列）で、「空白以外」を表示
 ８．A:D列をコピーして目的のシートのA1セルから貼り付け
 ９．複製シートを削除

 ご提示のデータがすべてであれば
 マクロの記録でもできそうです。
 （シート名が毎月変わるなら、９番は記録のみでは難しそうですが。）

 (HANA)

 ↑ お見事！
 一番確実だと思います。
 (seiya)

HANAさん、ありがとうございます。
今回はマクロの勉強の意味もありseiyaさんの方法を頑張って試してみます。

seiyaさんへ

マクロを使うのは自動記録する事くらいです。記録されたマクロを見て「セルを選択して」「そのセルに文字を入力して」と、書いてあるんだなと思う程度です。なのでseiyaさんが作ってくれた中では、『Sub test()、Range、 End With、End Sub』のそれぞれの単語？しかわかりません。

初級編と言われる書を見て勉強していますが、いざ自分で一から作るとなると全く何をしていいのやら・・・・

そんな状態では説明もして頂けないですかね？「この行でSheet1のここを選んで」とか無理ですか・・

と、編集していたら2回も衝突しました。理解するには程遠いようなので地道に勉強します。

HANAさん、seiyaさん、ありがとうございます。

（はとむぎ）

 それでは、まず

 VBHelp ファイルで

 SpecialCells
 Areas Collection

 を詳しく調べてください。
 わからなかったら、また質問してください。
 (seiya)

 ＞VBHelp ファイルで

 ＞SpecialCells
 ＞Areas Collection

・・・すみません、VBHelp　ファイルってどこにあるのですか？

（はとむぎ）

 コードを貼り付けた画面に　ヘルプ がありませんか？
 今日はこれで落ちますので、後は明日になります。
 (seiya)

 標準モジュールにseiyaさんのコードを貼りつけましたね。
 「SpecialCells」を反転させ[F1]を押してみてください。

 SpecialCellsに関するヘルプが開きます。

 単独で開くなら、VBEのメニューのヘルプから開けます。
 エクセルのヘルプと似たような顔をしていますが
 検索できるものが変わってきます。

 ちなみに、この掲示板は　文頭に半角スペースを入れると
 改行がそのまま反映されますよ。
_←ここに半角スペース。

 (HANA)

 処理に時間はかかりますが、こちらのマクロなら
 分かりやすいかもしれません。

 '------
Sub 一つずつ移動()
Dim i As Long, ir As Long
With Sheets("Sheet2")
    .Range("A2", .Range("D2").End(xlDown)).ClearContents
End With                'Sheet2のA2:D最終行までの範囲のデータをクリア
    ir = ir + 1         '見出し行があるので一つプラス
With Sheets("Sheet1")
    For i = 1 To .Range("A" & Rows.Count).End(xlUp).Row
                        'Sheet1の最終行まで処理を繰り返す
        If .Range("A" & i) <> "" And .Range("A" & i + 1) <> "" Then
                        'A列の該当行セルと、その一つ下のセルにともに入力があったら
            ir = ir + 1 '書き込み行番号を+1して
                        'Sheet2の各セルに、Sheet1の各セルの値を書き込む
            Sheets("Sheet2").Range("A" & ir).Value = .Range("A" & i).Value
            Sheets("Sheet2").Range("B" & ir).Value = .Range("A" & i + 1).Value
            Sheets("Sheet2").Range("C" & ir).Value = .Range("C" & i).Value
            Sheets("Sheet2").Range("D" & ir).Value = .Range("E" & i).Value
        End If
    Next                '次の行に関しての処理
End With
End Sub
 '------

 (HANA)

 遅くなってすみません。
 seiyaさん、VBHelp見たのですが全く理解できませんでした・・・・
 自分なりに再度一から勉強しなおして頑張ってみたのですが Dim myArea As の後にLong,String等の説明はありますが
 Area が基礎編では掲載されていないような気がするのですが？
 と、言う事でまずは　HANAさんに作って頂いたものを理解しようと考えました。

 が、しかし理解できない物が出てきました。 
 Dim i As Longの定義は理解できましたが5行目にある
 ir = ir + 1 
でなぜ1行下がって表示されはじめるのですか？

 （はとむぎ）

 予備知識として（すでにご存じでしたら、読み飛ばして下さい）
 Range("A" & i) は、A列のi行目のセルのことを表します。
 i=1だったら　A1セル、i=2だったら　A2セルの事です。

 そこで、各変数の値を一つずつ、順を追ってみていきます。

 最初、irは「0」の状態です。
 ＞    ir = ir + 1         '見出し行があるので一つプラス
 この行を過ぎると irは「1」になります。
 　　　ir =  0 + 1 ＝ 1 ですから。
 （・・・これって　ir = 1 って書くのと同じですね。）

 その下あたりからループ処理が始まります。
 データが10行目まであったら（ご提示のサンプルの状態）
 10回繰り返されます。

 1回目　＝　i=1 のとき
 　A1は空欄、A2は空欄なので IFの条件を満たしません
 　次のiの処理へ移ります。

 2回目　＝　i=2 のとき
 　A2が空欄　　　　　なので　次のiへ

 3回目　＝　i=3 のとき
 　A3にも、A4にも入力があり、IFの条件を満たします。
 ＞ir = ir + 1 '書き込み行番号を+1して
 　の行で
   ir =  1 +1 = 2　と計算されるので
 　ir=2　になります。
 　　Range("A" & ir)　は Range("A" & 2) ＝ A2セル　ですね。
 　ですから、
 ＞            Sheets("Sheet2").Range("A" & ir).Value = .Range("A" & i).Value
 　Sheet2のA2セルの値を、Sheet1のA3セルの値と等しくします。（入力　です。）
            ~ここが ir の値       ~ここが i の値

 4回目　＝　i=4のとき　条件を満たしません　次のiへ
 5回目　＝　i=5のとき　条件を満たしません　次のiへ
 6回目　＝　i=6のとき　条件を満たします。
 ＞ir = ir + 1 '書き込み行番号を+1して
 ir=3　になります。
 　　（3回目で irが2になった後　この変数の値は変化していませんから。）
 　Sheet2のA3セルに、Sheet1のA6セルの値を入れます。
            ~ここが ir の値   ~ここが i の値

 以降、i=10　まで繰り返します。

 iが、Sheet1の行（転記されるデータのあるセルの行）を意味し
 irが、Sheet2の行（転記先のセルの行）を意味します。

 転記条件が整ったら、irを一つプラスして
 先ほど転記した行の次の行へSheet1のデータを入れていきます。

 ＞5行目にある
 ＞ ir = ir + 1 
 ＞でなぜ1行下がって表示されはじめるのですか？
 このご質問は、最後までコードを読んでのご質問でしたか？
 それとも、5行目で止まってしまってのご質問だったのでしょうか・・・？

 5行目を削除すると、Sheet1のデータはSheet2の1行目から表示されます。
 既にこの上で書きましたが、最初 ir は「0」の状態で始まるからです。

 ir=0のままだと、最初に転記しようとする行は
 ir = 0+1 = 1 なので「1行目」になってしまいます。
 なので、その前に　irを「1」にしておきます。
 すると、最初に転記しようとする行が
 ir = 1+1 = 2 で、希望する「2」という値を得られます。

 分かりにくければ、他の書き方もしてみようと思いますので
 ご報告下さい。

 (HANA)

 HANAさんへ

 大変分かり易い説明ありがとうございます。十分理解できました。

 5行目を削除して実行し一行目から転記される事は確認していましたが
 ir=ir+1　数学的に考えて右辺と左辺がイコールになるのがどうしても理解できませんでした。
 ループして次に来るときには1プラスするのだとは思ったのですが、

 ＞For i = 1 To .Range("A" & Rows.Count).End(xlUp).Row

 の様に1から始まると言うコードが見当たらなかったのでirが0から始まるとは思ってませんでした。
 今回の事でかなり勉強になり更に頑張ってみようと思うようになりました。初心者の私に最後まで
 お付き合い頂きありがとうございました。

 それから、seiyaさん、今はコードが理解できないですがいつか分かる様に頑張ります。
 ありがとうございました。

 （はとむぎ）

 ご理解頂けたようで良かったです。

 同じ結果を得るための方法は一つでは有りません。
 先のマクロは「二行入力が続いたら転記行の先頭行」と考えて
 その様な作りになっていますが、よく考えると　そんなことをしなくても
 「3行目から初めて3行ずつが転記行の先頭」としても良いように思います。
 （寧ろ、今回はその様なルールでSheet1のデータが作られている様ですので
 　そうした方が良かった様に思います。）

 申し訳ないので、こちらのサンプルコードも載せておきます。

 '------
Sub 一つずつ移動2()
With Sheets("Sheet2")
    .Range("A2", .Range("D2").End(xlDown)).ClearContents
End With            'Sheet2のA2:D最終行までの範囲のデータをクリア
    ir = ir + 1     '見出し行があるので一つプラス
With Sheets("Sheet1")
    For i = 3 To .Range("A" & Rows.Count).End(xlUp).Row Step 3
                    'Sheet1の3行目から最終行まで【３つ飛ばしで】処理を繰り返す
        ir = ir + 1 '書き込み行番号を+1して
                    'Sheet2の各セルに、Sheet1の各セルの値を書き込む
        Sheets("Sheet2").Range("A" & ir).Value = .Range("A" & i).Value
        Sheets("Sheet2").Range("B" & ir).Value = .Range("A" & i + 1).Value
        Sheets("Sheet2").Range("C" & ir).Value = .Range("C" & i).Value
        Sheets("Sheet2").Range("D" & ir).Value = .Range("E" & i).Value
    Next            '次のiに関しての処理
End With
End Sub
 '------

 seiyaさんのコードは、ある日突然分かる様に成る日が来ると思いますし
 （分からないよりは分かる方が当然良いですが）
 分からなかったとしても、他の方法で対応できない　なんて事は無いと思いますので
 ゆっくり構えておくのが宜しいかと思います。

 (HANA)

 ループがお分かりのようですので取り敢えず大筋のところを

 例として

 a1:a3　a5:a7　a9:a11 を　Ctrl を押しながらそれぞれ選択すると

 Range("a1:a3,a5:a7,a9:a11") となります。
 カンマで区切られたそれぞれの範囲をArea
 全体が Areas になります。

 SpecialCells
 編集　-　ジャンプ - セル で指定したRange objectを返します。
 SpecialCells(2) は 定数（文字列、数値) (2 = xlCellTypeConstants)
 SpecialCells(2, 1) は同じく定数ですが数値のみ (1 = xlNumbers, 2 = xlTextValues)
 等、詳しくはヘルプを参照

 Columns(1).SpecialCells(2).Areas:

 で、A列で何らかの値が入力されているセルを抽出しています。
 結果、サンプルデータからは

 A3:A4,A6:A7,A9:A10

 という範囲が抽出されています。

 Areas に複数のAreaが存在する場合、各Areaに 1 からのIndexが割り当てられます。
 1 = A3:A4   2 = A6:A7   3 = A9:A10

 コードは、この各Areaをループして(Areas(i)) その中の対象セルを与えられた規則にしたがって
 他のセルへ書き出しています。
 (seiya)

 HANAさん、ありがとうございます。
 このコードは理解できました。書いてある事は理解できますが、実際に自分で作るにはまだまだ時間がかかりそうです。
 これは初級編くらいですかね？

 実はもう一つお願いがありまして、Sheet2に出来た表に罫線を引きたいのです。出来上がった表に引けば良いのですが、
 マクロで罫線まで引けたほうがスムーズかなと思いまして・・・お願い出来ますか？

 と、衝突・・・seiyaさんありがとうございます。
 >SpecialCells(2) は 定数（文字列、数値) (2 = xlCellTypeConstants)
 >SpecialCells(2, 1) は同じく定数ですが数値のみ (1 = xlNumbers, 2 = xlTextValues)

 と言うのは
 SpecialCell（2）　 はSpecialCell（xlCellTypeConstants)と同じ
 SpecialCells(2, 1) はSpecialCell（xlNumbers,xlTextValues)と同じと言う意味でしょうか？

 （はとむぎ）

 ちょっと、紛らわしかったですね...

 SpecialCells(xlCelltypeConstants)  SpecialCells(2)
 SpecialCells(xlCelltypeFormulas)  SpecialCells(-4123)
 は 第二引数 Type を指定出来ます。

 Type:
 xlNumbers(数値) = 1
 xlTextValues(文字) = 2
 xlLogical(論理値) = 4
 xlErrors(エラー値) = 16

 加算して複数のtypeを指定できます。
 指定しなければ全てが対象になります。

 SpecialCells(2, 1)  xlConstants, xlNumbers
 SpecialCells(2, 5)  xlConstants, xlNumbers + xlLogical

 実際にマクロを記録してどのようなコードになるか確認する方が早いですよ？
 (seiya)

 罫線の設定ですか。
 前の罫線の削除　とかは不要なんですかね？

 まず、前の罫線を消しましょう。
 前の罫線は、何行目まで有るか分からないので
 A:D列の罫線を削除する事にします。
 　Sheets("Sheet2").Range("A:D").Borders.LineStyle = False

 次に、罫線を設定する事を考えると
 範囲の左上のセルはA1セルですね。
 　Sheets("Sheet2").Range("A1")
 範囲の右下のセルは、列がD　行が　ir　ですね。
 　Sheets("Sheet2").Range("D" & ir)

 なので、この範囲は
   Sheets("Sheet2").Range(Sheets("Sheet2").Range("A1"), Sheets("Sheet2").Range("D" & ir))
 この範囲を               ~~~~~~~~~~~~左上~~~~~~~~~~~~  ~~~~~~~~~~~~~~右下~~~~~~~~~~~~~~
 　.Borders.LineStyle = True
 にすればこの範囲に罫線が引けます。

 Sheets("Sheet2")がたくさん出てくるので
 Withでまとめておきましょう。

 '------
With Sheets("Sheet2")
    .Range("A:D").Borders.LineStyle = False
    .Range(.Range("A1"), .Range("D" & ir)).Borders.LineStyle = True
End With
 '------

 End Sub　の上に入れて下さい。

 ＞書いてある事は理解できますが、実際に自分で作るにはまだまだ時間がかかりそうです。
 でも、同じパターンが出てきたら　このコードを参考に作れますよね。
 色々なコードに出会って、たくさんのパターンを知っていると
 コードも作れるように成ると思いますよ。

 また、上でも書きましたように
 「こうやらなきゃいけない」と言う場合も有りますが
 今回のものは、わりと「どうやっても出来る」ので
 色々試してみて下さい。

 例えば、罫線を消すのは
 ＞'Sheet2のA2:D最終行までの範囲のデータをクリア
 する前に、この範囲の罫線をクリアしても良いと思います。

 (HANA)

 ついでに、罫線

 Sub test()
 Dim myAreas As Areas, i As Long
 With Sheets("sheet1").Columns(1)
     On Error Resume Next
     Set myAreas = .SpecialCells(2).Areas
     On Error GoTo 0
     If myAreas Is Nothing Then Exit Sub
 End With
 With Sheets("sheet2")
     .UsedRange.Offset(1).Clear
     For i = 1 To myAreas.Count
         .Range("a" & Rows.Count).End(xlUp)(2) .Resize(, 4) _
         .Value = Array(myAreas(i).Cells(1).Value, _
         myAreas(i).Cells(2).Value, myAreas(i).Cells(1).Offset(, 2).Value, _
         myAreas(i).Cells(1).Offset(, 4).Value)
     Next
     .Range("a1").CurrentRegion.Borders.weight = xlThin
 End With
 End Sub
 (seiya)

 思い通りの罫線できました。ありがとうございます。前の罫線削除は確かに必要でした！！
 やはりHANAさんのコードは理解できたのですが、私は頭が悪いのでseiyaさんの方はちょっと時間かかりそうです・・・

 ＞Sub test()
 ＞Dim myAreas As Areas, i As Long
 ＞With Sheets("sheet1").Columns(1)⇔‘この（1）はA列を意味する？‘
 ＞    On Error Resume Next
 ＞    Set myAreas = .SpecialCells(2).Areas⇔‘この（2）はxlcelltypeconstantsを意味する？‘
 ＞    On Error GoTo 0
 ＞    If myAreas Is Nothing Then Exit Sub
 ＞    For i = 1 To myAreas.Count
 ＞        Sheets("sheet2").Range("a" & Rows.Count).End(xlUp)(2) _
 ＞        .Resize(, 4).Value = Array(myAreas(i).Cells(1).Value, _
 ＞        myAreas(i).Cells(2).Value, myAreas(i).Cells(1).Offset(, 2).Value, _
 ＞        myAreas(i).Cells(1).Offset(, 4).Value)
 ＞    Next
 ＞　　.Range("a1").CurrentRegion.Borders.weight = xlThin
 ＞End With
 ＞End Sub

 上記2点の（）はこんな意味であってますか？実際にコード上でSpecialCells(xlcelltypeconstants).にマウスを持っていくと
 「=2」と表示され、実行しても結果は同じ様に見えましたが。

 （はとむぎ）

 そのコードは私が最後に提示したコードとは違っていますよ？

 1) も 2) もそのとおりです。

 MsgBox myAreas.Address

 を　Set myAreas = .SpecialCells(2).Areas
 の一行下に挿入して、Address を確認してください。
 (seiya)

 すみません、写し間違えでした。しかし、seiyaさんの罫線付で作って頂いたコードが構文エラーとなり
 うまくいきません。

         .Range("a" & Rows.Count).End(xlUp)(2) .Resize(, 4) _
         .Value = Array(myAreas(i).Cells(1).Value, _
         myAreas(i).Cells(2).Value, myAreas(i).Cells(1).Offset(, 2).Value, _
         myAreas(i).Cells(1).Offset(, 4).Value)

 この部分が赤く表示されていますが、どこがおかしいのでしょうか？

 （はとむぎ）

 そこは　With Statement で括っただけなのですが...

         .Range("a" & Rows.Count).End(xlUp)(2) .Resize(, 4).Value = _
         Array(myAreas(i).Cells(1).Value, myAreas(i).Cells(2).Value, _
         myAreas(i).Cells(1).Offset(, 2).Value,myAreas(i).Cells(1).Offset(, 4).Value)

 にしてみてください。
 (seiya)

 やはりダメでした。が、一番最初に頂いたコード

          Sheets("sheet2").Range("a" & Rows.Count).End(xlUp)(2) _
          .Resize(, 4).Value = Array(myAreas(i).Cells(1).Value, _
          myAreas(i).Cells(2).Value, myAreas(i).Cells(1).Offset(, 2).Value, _
          myAreas(i).Cells(1).Offset(, 4).Value)

 をコピペすると実行するとうまくできました。その後先頭の　Sheets("sheet2")　を消去しても
 ちゃんと実行できました。なぜかよくわからないですが解決です。

 （はとむぎ）

コメント返信：

[ 一覧(最新更新順) ]

[[20090407134813]] 『抽出マクロ』（はとむぎ） ページの最後に飛ぶ

[[20090407134813]]　『抽出マクロ』（はとむぎ）　ページの最後に飛ぶ