VBAで特定の条件だったらセル番地を記載

質問

VBAでセルの値を見て、特定の条件だったらそのセル番地を記載したい。

以下のようになっているデータがあります。

0
0
0
0
35351←●１ブロック目の始まりのセル
319241
2412
421414
351315←●１ブロック目の終わりのセル
0
0
0
0
0
43624←■２ブロック目の始まりのセル
3252
53252
452←■２ブロック目の終わりのセル
0
0
0

0が入っている行が数行あった後、数値が入っている行が数行続き、また0が入っている行、0より大きい数値が入っている行、と繰り返されているデータがあります。
0が入っている行数、0より大きい数値が入っている行数は固定ではありません。

0より大きい数値が入っている数行のデータを１ブロックとします。
１つのシートでのブロック数も固定ではありません。

データ行は4098行までで固定です。

このようなデータの１ブロックごとの始まりのセル番地と終わりのセル番地を出し、シートに記載したいです。

考えたのは２行ずつセルの値を見て、0と0より大きい数値の並びになっていればブロック始まりのセル番地として記載し、より大きい数値と0という並びになっていればブロック終わりのセル番地として記載するという方法です。

もっと単純な処理で済むようなものがあれば教えていただきたいです。

回答No.1

keithin · ベストアンサー

１行目にはタイトル行を設け，２行目から実データにします。

sub macro1()
　dim h as range
　dim n
　application.screenupdating = false
　on error resume next

’対象範囲を抽出する
　range("A1:A4098").autofilter field:=1, criteria1:=">0"

’順繰り書き出していく
　for each h in range("A2:A4098").specialcells(xlcelltypevisible).areas
　n = n + 1
　worksheets("Sheet2").cells(n, "A") = h.address
　next
　activesheet.autofiltermode = false
　application.screenupdating = true
end sub

お礼

オートフィルターで対応するとは目からウロコでした！
こちらの方法で希望のデータを得ることが出来ました。
ありがとうございました。

回答No.6

mitarashi

#5です。改めて皆様のコードを眺めていたら、
コード記述の作法が違うので見落としておりましたが、keithinさんのコードと一緒ですね。
取り下げさせていただきます。

回答No.5

mitarashi

面白そうなので参戦してみます。
A1は勝手に列見出しであるとさせていただきます。
結果は、2番目のシートに書き出します。A列開始番地、B列終了番地です。
Sub test()
Dim targetRange As Range, myArea As Range, destRange As Range

With ActiveSheet
Set targetRange = .Range(.Range("A1"), .Range("A" & .Rows.Count).End(xlUp))
Set destRange = Sheets(2).Cells(1)
targetRange.AutoFilter field:=1, Criteria1:="<>0"
For Each myArea In Intersect(targetRange, targetRange.Offset(1, 0)).SpecialCells(xlCellTypeVisible).Areas
destRange.Value = myArea.Cells(1).Address
destRange.Offset(0, 1).Value = myArea.Cells(myArea.Cells.Count).Address
Set destRange = destRange.Offset(1, 0)
Next myArea
.AutoFilterMode = False
End With
End Sub

回答No.4

xls88

数式の戻り値でなく、生の実データということなら

Dim crng As Range
Dim brng As Range
Dim c As Range
Dim i As Long

Application.ScreenUpdating = False
Set crng = Range("A2", Range("A" & Rows.count).End(xlUp))
crng.Replace 0, ""
Set brng = crng.SpecialCells(xlCellTypeBlanks)
Set crng = crng.SpecialCells(xlCellTypeConstants)

For Each c In crng.Areas
i = i + 1
MsgBox c.Address & vbLf & _
i & "ブロック開始セル " & Split(c.Address, ":")(0) & vbLf & _
i & "ブロック終了セル " & Split(c.Address, ":")(1)
Next
brng.value = 0
Application.ScreenUpdating = True

回答No.3

mu2011

一例です。
シート１のＡ列のデータブロックをシート２のＡ列に抽出します。
シートタブ上で右クリック→コードの表示→以下のコード貼り付け→Ｆ５キー押下して下さい。

Sub sample()
範囲 = "A1:A4098"
Application.ScreenUpdating = False
Range(範囲).Select
Cells.Replace What:="0", Replacement:="", LookAt:=xlWhole, _
SearchOrder:=xlByRows
For Each gp In Selection.SpecialCells(xlCellTypeConstants).Areas
i = i + 1
Worksheets("sheet2").Cells(i, 1) = gp.Address(0, 0)
Next
Selection.SpecialCells(xlCellTypeBlanks).Select
Selection.FormulaR1C1 = "0"
Range("A1").Select
Application.ScreenUpdating = True
End Sub

回答No.2

tom04

こんにちは！
一例です。
↓の画像のようにSheet1のデータは2行目以降にあり、Sheet2の2行目以降に表示するとします。

とりあえず、データのかたまりは2行以上続いているという前提です。

画面左下のSheet1のSheet見出し上で右クリック　→　コードの表示　→　VBE画面に
↓のコードをコピー＆ペーストしてマクロを実行してみてください。

Sub test() 'この行から
Dim i As Long
Dim ws As Worksheet
Set ws = Worksheets(2)
i = ws.Cells(Rows.Count, 1).End(xlUp).Row
If i > 1 Then
ws.Rows(2 & ":" & i).ClearContents
End If
Application.ScreenUpdating = False
If Cells(2, 1) <> 0 Then
ws.Cells(Rows.Count, 1).End(xlUp).Offset(1) = _
WorksheetFunction.Substitute(Cells(2, 1).Address, "$", "")
End If
For i = 2 To 4098
If Cells(i, 1) <> 0 Then
If Cells(i - 1, 1) = 0 And Cells(i + 1, 1) <> 0 Then
ws.Cells(Rows.Count, 1).End(xlUp).Offset(1) = _
WorksheetFunction.Substitute(Cells(i, 1).Address, "$", "")
ElseIf Cells(i - 1, 1) <> 0 And Cells(i + 1, 1) = 0 Then
ws.Cells(Rows.Count, 2).End(xlUp).Offset(1) = _
WorksheetFunction.Substitute(Cells(i, 1).Address, "$", "")
End If
End If
Next i
Application.ScreenUpdating = True
End Sub 'この行まで

※　仮にある行にデータがあり、上下のセルが「0」といったデータの場合別途コードを考える必要があります。

参考になりますかね？m(_ _)m