エクセル関数、またはVBA

質問

どなたか教えてください。

Ｂ列に半角数字か空セルがあります。
Ａ列にＢ列の一定の行数(下記だと４行)の数字の和があります。
----------
Ａ　Ｂ　Ｃ
３　１　　
　　１　　
　　１　　

４　０　　
　　１　　
　　３　　
　　０　　
３　０　　

　　２　　
　　１　　
----------
これを以下のようにＡ列の数字を対応する４行中のＢ列がゼロでも空セルでもない行に移動させたいのです。
----------
Ａ　Ｂ　Ｃ
３　１　　
　　１　　
　　１　　

　　０　　
４　１　　
　　３　　
　　０　　
　　０　　

３　２　　
　　１　　
----------
実は経理の帳簿の貸借なのですが、関数かマクロでできないでしょうか？
自分なりに考えてみたのですが、頭がパンクしました・・・
どうかお助け下さい。

回答No.4

n-jun

＃２です。

私の勘違いだったのかな？
＃１の補足から、ワークシートのイベントに絡ませるのかとも思ったりしましたが、
Ａ列をどのタイミングで変化させたかったのでしょう。

お礼

n-jun様

言葉不足で申し訳ありません。
なかなか言葉が見つからず、画像付で再度質問投稿させていただきました。
お手すきの時にご覧いただければ嬉しいです。

どうぞ宜しくお願いします。
http://oshiete1.goo.ne.jp/qa4693135.html

回答No.3

AKARI0418

すでにA列には値が入っているということでよろしいですよね？

Sub Test()
Dim RangeA As Range
Dim RangeB As Range
Dim ANumber() As Integer
Dim Work As String
Dim counter As Integer
Dim SetFlag As Boolean
Dim i As Long

'A列の1行目からデータのある最終行までを取得する。
Set RangeA = Range(Cells(1, 1), Range("$A$65536").End(xlUp))
'配列の初期化
ReDim ANumber(0)
counter = -1

'A列にある数字を配列に格納する
For i = 1 To RangeA.Rows.Count
Work = RangeA.Cells(i, 1).Value
If IsNumeric(Work) = True Then
If CInt(Work) > 0 Then
counter = counter + 1
ReDim Preserve ANumber(counter)
ANumber(counter) = CInt(Work)
RangeA.Cells(i, 1).Value = vbNullString
End If
End If
Next i

Set RangeA = Nothing

'A列の1行目からB列のデータのある最終行までを取得する。
Set RangeB = Range(Cells(1, 1), Range("$B$65536").End(xlUp))

SetFlag = False
counter = -1

'B列を１行づつ値を確認し、数字でかつ1以上の場合、配列の値をセットしセット済みフラグを立てる。
'B列の値が空白の場合はセット済みフラグを落とす
For i = 1 To RangeB.Rows.Count
Work = RangeB.Cells(i, 2).Value
If IsNumeric(Work) = True And SetFlag = False Then
If CInt(Work) > 0 Then
counter = counter + 1
RangeB.Cells(i, 1).Value = ANumber(counter)
SetFlag = True
End If
ElseIf Work = vbNullString Then
SetFlag = False
End If
Next i

End Sub

お礼

AKARIO418様

回答ありがとうございます。
早速試したところ、どうしてもうまくいかない行があります・・・。

質問を立て直させていただきました。
お時間がある時にもう一度ご覧いただければと思います。

どうぞ宜しくお願いします。
http://oshiete1.goo.ne.jp/qa4693135.html

回答No.2

n-jun

＃１です。

数式での回答を待ってみて下さい。
提示したコードは値を編集後に実行する必要があり、値の編集直後に実行されるものではないので。

回答No.1

n-jun

Sub try()
Dim r As Range
Dim rr As Range
Dim rs As Range

For Each r In Range("B1", Cells(Rows.Count, 2).End(xlUp)).SpecialCells(xlTextValues).Areas

For Each rr In r

If rr.Value <> 0 Then
Set rs = rr.Offset(, -1)
Exit For
End If

Next

If Not rs Is Nothing Then
rs.Value = WorksheetFunction.Sum(r)
Set rs = Nothing
End If

Next

Set rs = Nothing
End Sub

数式は苦手ですのでマクロで。
ざっとですが、こんな感じの事でしょうか？

補足

n-jun様

早速のアドバイスありがとうございます！
質問の例で試したところ、Ａ列の中段下段の４と３が意とする行にコピーされたのですが、元の場所にも残ったままでした。
また、別の数字のコンビネーションで試したところ、一部数字が変わったり、Ｂ列が上から０１０１となる場所ではＡ列に変化がありませんでした。
やはり難しいのでしょうか・・・。