Excel VBA データの入っているセルの取り出し

質問

Excel VBA データの入っているセルの取り出し

Excel2007使用です。
大きなセル範囲の中にデータが点在している場合に、そのデータを一か所にまとめるマクロを作りたいです。セル範囲は決まっています（A1:Q100）。最終的には隣のセルの1列にまとめたいです。

以下のようなマクロを作ってみましたが、いずれも作動しませんでした（エラーメッセージも出ず）
NullをEmptyに変えてみても同じでした。
（ややこしいですが、アクティブセルはSheet2、Sheet1へ貼り付けたい）

（とりあえずシート内で列上部にまとめようとした）
Dim myRange As Range
For Each myRange In Range("A1:Q100")
If myRange.Value = Null Then
myRange.Delete xlShiftUp
End If
Next myRange
End Sub

（1行1列ずつの参照をループさせて「空白でない」セルを切り取り-貼り付けさせようとした）
Worksheets("sheet2").Activate
Dim Gyou As Integer
Dim Retsu As Integer
For Gyou = 1 To 100
For Retsu = 1 To 17
If Cells(Gyou, Retsu).Value = Not Null Then
Cells(Gyou, Retsu).Cut Destination:=Worksheets("sheet1").Cells(5, 2)
End If
Next Retsu
Next Gyou
End Sub

また、以下のマクロは、実行すると現状のままSheet1のE列以降に移るだけで、データのあるセルだけがまとまるという状態にはなりません。
Range("A1:Q100").SpecialCells(xlCellTypeVisible).Cut Destination:=Worksheets("Sheet3").Range("E1")
End Sub

以下は某サイトで、まさに「空白セルを削除しデータの入ってるセルを上詰めにする」というマクロが紹介されていたので、加工してやってみましたが、「RangeクラスのDeleteメソッドが失敗しました」という実行時エラーが出てできませんでした。
Dim WS As Worksheet
Dim myRng As Range
Dim Lrow As Long
Set WS = Worksheets("Sheet1")
Lrow = WS.Range("A" & CStr(Rows.Count)).End(xlUp).Row
Set myRng = WS.Range("A1:A" & CStr(Lrow))
myRng.SpecialCells(xlCellTypeBlanks).Delete xlShiftUp
End Sub

データの入っているセルだけを取り出して一つの列にまとめたいのですが、どうしたらいいのでしょうか。

回答No.3

xls88 · ベストアンサー

A1:Q100には、データが入力されたセルと、何も入力されていない空白のセルのみですか？
数式があるとか、空白に見えるセルは無いという事で良かったですか？

データセルを同じシートのS1以下1列に書き出してみました。

Dim rng As Range
Dim n As Integer
Dim i As Integer

Set rng = Range("A1:Q100")
For i = 1 To rng.Columns.Count
On Error Resume Next
With rng.Columns(i).SpecialCells(xlCellTypeConstants, 23)
.Copy Range("S1").Offset(n)
n = n + .Count
End With
On Error GoTo 0
Next i

補足

質問に書いた「最終的には隣のセルの一列にまとめたい」は「隣のシートに」の間違いでした。
大変申し訳ありませんでした。

が、xls88様の回答のコピー先をSheet1のE列にしたら上手くいきました。

ka_na_de様の回答でも同じ結果を得られたのですが、xls88様の方が簡単だったので今回はこちらを参考にさせていただきました。

ただ、大変お恥ずかしいことに、意味がよくわからない部分があります。
>With rng.Columns(i).SpecialCells(xlCellTypeConstants, 23)
の「23」はなにを表しているのでしょうか？

申し訳ありませんがお教えいただきたく、重ねてよろしくお願いいたします。

回答No.6

tom04

こんにちは！
すでに回答は色々出ていますので、参考程度で・・・

関数での方法は
Sheet2のA1セルに
=IF(COUNTA(Sheet1!A$1:A$100)<ROW(A1),"",INDEX(Sheet1!A$1:A$100,SMALL(IF(Sheet1!A$1:A$100<>"",ROW($A$1:$A$100)),ROW(A1))))

これは配列数式になりますので、この画面からコピー＆ペーストしただけではエラーになると思います。
貼り付け後、F2キーを押す、またはA1セルをダブルクリック、または数式バー内で一度クリックします。
編集可能になりますので、Shift+Ctrlキーを押しながらEnterキーで確定します。
数式の前後に｛　｝マークが入り配列数式になります。
これを列方向と行方向にオートフィルでコピーすると、空白が無視され上詰めになると思います。

VBAでは一例ですが
まずSheet1すべてをコピー→Sheet2に貼り付けします。そしてSheet2のシート見出し上で右クリックし
↓のコードを貼り付けマクロを実行してみてください。

Sub test()
Dim i, j As Long
For i = 100 To 1 Step -1
For j = 1 To Cells(1, Columns.Count).End(xlToLeft).Column
If Cells(i, j) = "" Then
Cells(i, j).Delete (xlUp)
End If
Next j
Next i
End Sub

A列のデータ行が他の列以上であれば、↓のコードで最終行を取得して
もう少し短時間でマクロが実行できると思います。

Sub test2()
Dim i, j As Long
For i = Cells(Rows.Count, 1).End(xlUp).Row To 1 Step -1
For j = 1 To Cells(1, Columns.Count).End(xlToLeft).Column
If Cells(i, j) = "" Then
Cells(i, j).Delete (xlUp)
End If
Next j
Next i
End Sub

どうも長々と失礼しました。m(__)m

お礼

質問で「隣のセルに」と書いたのは「隣のシートに」の間違いでした、大変もうしわけありません。

ご丁寧な回答ありがとうございます。

今回はNo.2、No.3の回答者様のを参考にさせていただいて、なんとか意図する状態にできました。

回答No.5

imogasi

何で複雑に考える必要があるのかな
Sub test01()
k = 2
Dim myRange As Range
For Each myRange In Range("A1:Q100")
If myRange = "" Then
Else
Cells(k, "z") = myRange
k = k + 1
End If
Next myRange
End Sub
でZ列に縦１列にデータが集るよ。
ただ空白のセルの質問者が込めている意味は明白で無いが。
関数の結果が""であるものはこれで察知できるはず。Cells(k, "z") はCells(k, "z").Valueの略で
来歴によらず、「セルの値」を見るものだから。
""、NULL、Emptyについては別に勉強して。またはそれに特化して質問してみたら。
WEBで「エクセルVBA　NULL」「エクセルVBA　Empty」で照会。
例えばNULLではhttp://oshiete.homes.jp/qa2750911.html
のWendy02さんの説明を読んでみてください.
その中に「私は、数年、VBAを書いておりますが、Null値を積極的に使った経験はありません。」と書いておられますが、私もこの１０年間の回答で、Null,Emptyを意識しなくても済みましたが。

お礼

質問で「最終的に隣のセルの1列にまとめたい」と書いたのは「隣のシートの」の間違いでした。
大変申し訳ありません。

NullとEmptyについては私も、VBAでは使わないというのは聞いていましたが、今回はセル内のデータがテキストであるためか、最初のうち「""」を使っているうちはエラーになって先に進めず、NullやEmptyにしたらとりあえず先に進む事ができたので、こちらを使わなければいけないのかなあ・・・と思いながらやっていました。

もしかして、セル内のデータが数値がテキストか、ということでも大きな違いが出るのでしょうか？質問内に書くべきでしたでしょうか。
もしそうであれば、もうホントに初心者とも言えないくらいの初心者で、マニュアルと首っ引きで毎日苦労しているので、なにとぞお許しいただきたいと思います。

なんにせよ、ご丁寧な回答、ありがとうございました。

回答No.4

ka_na_de

#2です。
以前のコードでは=""などの文字数０のデータを除けなかったので改良しました。
値（定数）、および、数式で計算された値を一列に並べます。

Sheet2　の　A1：Q100　のデータを
Sheet1　の　E列に並べるように作りました。

注）Sheet1　の　E1セルに見出しがある前提です。
　　Sheet2　の　S列を作業列として使います。

Sub test2()
　　Dim Ws1 As Worksheet
　　Dim Ws2 As Worksheet
　　Dim myRange As Range
　　Dim i As Long

　　Set Ws1 = Worksheets("Sheet1")
　　Set Ws2 = Worksheets("Sheet2")
　　Set myRange = Ws2.Range("A1:Q100")

　　Ws2.Range("S1").Value = Ws1.Range("E1").Value

　　For i = 1 To myRange.Columns.Count
　　　　myRange.Resize(, 1).Offset(, i - 1).Copy
　　　　Ws2.Range("S" & Rows.Count).End(xlUp).Offset(1).PasteSpecial Paste:=xlPasteValues
　　Next i

　　With Ws2.Columns("S")
　　　　If Ws2.AutoFilterMode Then Ws2.AutoFilterMode = False
　　　　.AutoFilter Field:=1, Criteria1:="<>"
　　　　.Copy Destination:=Ws1.Range("E1")
　　　　.Delete
　　End With

　　Set Ws1 = Nothing
　　Set Ws2 = Nothing
　　Set myRange = Nothing
End Sub

回答No.2

ka_na_de

Sheet2　の　A1：Q100　のデータを
Sheet1　の　E列に並べるように作りました。

Sheet1　の　E1セルに見出しがあればE2以降に並びます。

Sub test1()
　　Dim Ws1 As Worksheet
　　Dim Ws2 As Worksheet
　　Dim myRange As Range
　　Dim i As Long

　　Set Ws1 = Worksheets("Sheet1")
　　Set Ws2 = Worksheets("Sheet2")
　　Set myRange = Ws2.Range("A1:Q100")

　　For i = 1 To myRange.Columns.Count
　　　　myRange.Resize(, 1).Offset(, i - 1).Copy _
　　　　　　　　Destination:=Ws1.Range("E" & Rows.Count).End(xlUp).Offset(1)
　　Next i

　　Ws1.Columns("E").SpecialCells(xlCellTypeBlanks).Delete Shift:=xlUp

　　Set Ws1 = Nothing
　　Set Ws2 = Nothing
　　Set myRange = Nothing
End Sub

お礼

質問に書いた「隣のセルの1列にまとめたい」は「隣のシートの」の間違いでした。
大変もうしわけありません。

ka_na_deさまの回答でほぼ、意図していた状態にすることができました。
ありがとうございました。

回答No.1

KURUMITO

取り合えず次のようにすることで行を詰めることができますね。ご参考までに。

For RowPos = 1 To 100
If WorksheetFunction.CountBlank(Range(Range("A" & RowPos), Range("D" & RowPos))) = 4 Then
Rows(RowPos).Delete xlShiftUp
End If
Next

お礼

質問文で「隣のセルの1列にまとめたい」は「隣のシート」の間違いでした。
大変申し訳ありません。

お示しいただきましたやり方だと4行分が上に詰まるだけのようでしたので、今回は指定範囲内にランダムに入っているデータの取り出しになるため、ちょっとうまくいきませんでした。

しかしながら、行を詰める考え方としては参考にさせていただきました。
ありがとうございました。

今回はNo.3さまの回答を参考にさせていただきました。