いい方法を教えてください（VBAについての質問）

質問

よろしくお願いします。

ある処理についてプロシージャを作成しました。
それは「毎回データの行数・列数の異なるデータから必要な列のデータだけを取り出して別のシートにコピーして貼り付ける」処理です。

具体的にはセルのA2以下にデータを貼り付けて必要な列の1行目空白セルに1を、不要な列は0を入れ、必要なデータ（1を入れた列にあるデータ）だけ取り出すという処理です。

　Do Until ActiveCell.Value = ""
　　If Selection.Value = "1" Then
　　Selection.Offset(1, 0).Select
　　Range(Selection, Selection.End(xlDown)).Copy _
　　Destination:=mySht.Range("IV1").End(xlToLeft).Offset(0, 1)
　　Selection.End(xlUp).Offset(0, 1).Select
　　Else
　　Selection.Offset(0, 1).Select
　　End If
　Loop
↑こんな感じで書きました。
myShtは変数で、必要データ貼り付け用に作成したシートです。

使ってみて穴に気付きました。
データに空白があった時に、空白以後のデータがコピーされないのです。そういう書き方なので当然ですが・・・。

範囲の指定をその列のデータの最初から空白関係なくデータのある最終行までにしようとあれこれと試しましたがことごとくうまくいきません。
これが1つ目の悩みです。

もう1つは
　　Range(Selection, Selection.End(xlDown)).Copy _
　　Destination:=mySht.Range("IV1").End(xlToLeft).Offset(0, 1)
の部分、取り出した列のコピーを別のシート（mySht）に左寄せで順番に詰めてコピーしていくようにしたのですが、この記述だと1列目が空いてしまいます。
ですから実際はこの後1列目を削除する処理をしています。
この1列目の削除というのが本来不要な作業なので、なんだかイヤなのです。

何かいい方法を教えてください。
ヒントみたいなものでもうれしいです。

回答No.1

KenKen_SP · ベストアンサー

こんにちは。KenKen_SP です。

> 範囲の指定をその列のデータの最初から空白関係なくデータのある
> 最終行までにしようと...

いろいろありますが、UsedRange や CurrentRegion でデータ範囲を
取得して、最終列を求めるといいでしょう。

> この記述だと1列目が空いてしまいます。

End(xlToLeft).Column の戻り値が 1 のときは Offset しなければ良い
です。下記のコードは多少記述が違いますが、考え方は一緒です。

こんな感じ。

Sub SampleMacro()

　　Dim mySht As Worksheet
　　Dim lngC　As Long
　　Dim lngR　As Long
　　Dim i　　 As Long

　　With ThisWorkbook
　　　　'貼り付け先シート定義
　　　　Set mySht = .Sheets("Sheet2")
　　　　'貼り付け先列番号取得
　　　　lngC = mySht.Cells(1, "IV").End(xlToLeft).Column
　　　　If lngC <> 1 Then
　　　　　　'既存データが在れば1列横に再設定
　　　　　　lngC = lngC + 1
　　　　End If
　　End With

　　'元データ（アクティブシート）の最大行番号を取得
　　lngR = ActiveSheet.UsedRange.Rows.Count

　　With ActiveSheet
　　　　'元データの最大列番号までループ処理
　　　　For i = 1 To .UsedRange.Columns.Count
　　　　　　If .Cells(1, i).Value = 1 Then
　　　　　　　　'コピー＆ペースト
　　　　　　　　.Range(.Cells(1, i), .Cells(lngR, i)).Copy _
　　　　　　　　Destination:=mySht.Cells(1, lngC)
　　　　　　　　'次の貼り付け先となる列番号にカウントアップ
　　　　　　　　lngC = lngC + 1
　　　　　　End If
　　　　Next i
　　End With

　　Set mySht = Nothing

End Sub

お礼

ああっスゴい！・・・しかも回答が早い・・・。
ありがとうございました。

以前も回答者様には教えていただきましたが、おかげさまで今回のは前よりはどういう構造かがわかります！

早速、実際のブックに組み込ませてもらって試してみます。

一番ショックだったのは自分の書いたものと処理速度が全然違う事です。沢山のデータを処理するんだから仕方が無いと思っていましたが・・・。
はあ、奥が深い・・・。

回答No.2

Wendy02

こんにちは。

ちょっと最初の出だしがよく見えていない部分がありますが、

＞データに空白があった時に、空白以後のデータがコピーされないのです。そういう書き方なので当然ですが・・・。

それは、
Range(Selection, Selection.End(xlDown)).Copy　

これが理由だからですね。下から上にというのは、こういう書き方ですと、ややこしくなりますからね。でも、それ以外は、コードとしては、私は良くできていると思いますね。

一応、私なりに、オプションをつけたりして、移植しているつもりではいるのですが、失敗していたら、すみませんね。

それから、Selection は、ActiveCell のほうが、無難ですね。

＞左寄せで順番に詰めてコピーしていくようにしたのですが、この記述だと1列目が空いてしまいます。

なかなか、きれいにそのロジックを立てるのは難しいですね。Excel VBAを書く人は、それぞれ、自分の方法を持って書いているようです。

'--------------------------------------------
Sub FindOneAndCopyColumn()
　 Dim c As Range
　 Dim mySht As Worksheet
　 Dim PasteRng As Range
　 Dim i As Integer
　 Dim j As Integer
　 Dim k As Integer
　 Set mySht = Worksheets("Sheet2")

　 'mySht の１行目のチェック・ロジック
　 'ここは、列全体に及ばせることも可能です。
　 Set PasteRng = mySht.Range("IV1").End(xlToLeft)
　 i = mySht.Range("IV1").End(xlToLeft).Column
　 j = WorksheetFunction.CountA(PasteRng.EntireRow)
　 If j > 0 And i <> j Then
　　　MsgBox "空の列が存在していますので中止します。", vbInformation
　　　Exit Sub
　 ElseIf j = 0 Then
　　　k = 0
　 Else
　　　k = 1
　 End If

　 With ActiveSheet
　　　For Each c In .Range("A1", .Range("IV1").End(xlToLeft))
　　　　 If c.Value = 1 Then
　　　　　　.Range(c.Offset(1), .Cells(65536, c.Column).End(xlUp)).Copy _
　　　　　　PasteRng.Offset(, k)
　　　　　　k = k + 1
　　　　 End If
　　　Next c
　 End With

　　Set mySht = Nothing: Set PasteRng = Nothing
End Sub

お礼

回答ありがとうございます。
お礼が遅くなりました。

これもまた試したところキチンとすばやく動作しました。
今回は#1様の記述をプロシージャの中にはまるように少し修正して使わせていただきました。
ですが同じ結果を求めるやり方でも色々なやり方があるのだなと勉強になりました。どうやら自分はまだ変数をうまく使いこなすのが不慣れなようです。課題ですね。
ありがとうございます。