Excel VBA質問箱 IV

当質問箱は、有志のボランティア精神のおかげで成り立っています。
問題が解決したら、必ずお礼をしましょうね。
本サイトの基本方針をまとめました。こちら をご一読ください。

投稿種別の選択が必要です。ご注意ください。
迷惑投稿防止のため、URLの入力を制限しています。ご了承ください。


3951 / 13644 ツリー ←次へ | 前へ→

【59109】マクロでのオートSUM tantan 08/11/29(土) 0:04 質問[未読]
【59110】Re:マクロでのオートSUM Yuki 08/11/29(土) 8:13 発言[未読]
【59111】Re:マクロでのオートSUM Hirofumi 08/11/29(土) 8:14 発言[未読]
【59116】Re:マクロでのオートSUM Hirofumi 08/11/29(土) 11:46 発言[未読]
【59130】Re:マクロでのオートSUM tantan 08/11/29(土) 23:06 質問[未読]
【59131】Re:マクロでのオートSUM Hirofumi 08/11/30(日) 0:18 回答[未読]
【59132】Re:マクロでのオートSUM Hirofumi 08/11/30(日) 0:43 回答[未読]
【59133】Re:マクロでのオートSUM tantan 08/11/30(日) 0:47 質問[未読]
【59134】Re:マクロでのオートSUM Hirofumi 08/11/30(日) 1:45 回答[未読]
【59151】Re:マクロでのオートSUM tantan 08/11/30(日) 18:54 質問[未読]
【59157】Re:マクロでのオートSUM Hirofumi 08/11/30(日) 20:48 回答[未読]
【59166】Re:マクロでのオートSUM tantan 08/12/1(月) 0:28 質問[未読]
【59168】Re:マクロでのオートSUM SS 08/12/1(月) 9:47 発言[未読]
【59195】Re:マクロでのオートSUM tantan 08/12/2(火) 0:57 質問[未読]
【59196】Re:マクロでのオートSUM ichinose 08/12/2(火) 8:09 発言[未読]
【59263】Re:マクロでのオートSUM tantan 08/12/4(木) 0:41 お礼[未読]
【59266】Re:マクロでのオートSUM ichinose 08/12/4(木) 6:22 発言[未読]
【59197】Re:マクロでのオートSUM Jaka 08/12/2(火) 9:33 発言[未読]
【59224】Re:マクロでのオートSUM Hirofumi 08/12/2(火) 18:43 回答[未読]
【59225】Re:マクロでのオートSUM Hirofumi 08/12/2(火) 19:24 回答[未読]
【59262】Re:マクロでのオートSUM tantan 08/12/4(木) 0:36 お礼[未読]
【59283】Re:マクロでのオートSUM Hirofumi 08/12/4(木) 19:29 回答[未読]
【59310】Re:マクロでのオートSUM tantan 08/12/5(金) 18:06 お礼[未読]
【59228】Re:マクロでのオートSUM n 08/12/2(火) 21:24 発言[未読]
【59264】Re:マクロでのオートSUM tantan 08/12/4(木) 1:50 質問[未読]
【59265】Re:マクロでのオートSUM n 08/12/4(木) 3:06 発言[未読]
【59311】Re:マクロでのオートSUM tantan 08/12/5(金) 18:08 お礼[未読]

【59109】マクロでのオートSUM
質問  tantan  - 08/11/29(土) 0:04 -

引用なし
パスワード
   2点質問させてください。

1.行の挿入
 2  左記のように行方向の数字に対し、同じ数字の最後に行を
 2  自動的に挿入する(2の最後、3の最後、5の最後など)
 2  にはどうしたらよいでしょうか?
 3
 3
 5
 5

2.マクロでのオートSUM

上記の続きでもありますが、通常エクセルの関数では
オートSUMΣをクリックすると自動的に
隣接する数字の合計を拾ってくると思います。
上記の例で言えば、2の最後に挿入した行で2の合計を
求めたいのですがマクロではどのようにすればよいので
しょうか?
 2
 2
 2
 =SUM(A1:A3)←=6

これをマクロの記録でとると
ActiveCell.FormulaR1C1 = "=SUM(R[-3]C:R[-1]C)"
となります。
集計したい行数は毎回変化するので、これでは使えません。
現在は、合計を求めたいところでオートSUMを使って
手作業でやっていますが、マクロで自動化したいと
思っております。
初心者で申し訳ありませんがどなたか教えてください。

【59110】Re:マクロでのオートSUM
発言  Yuki  - 08/11/29(土) 8:13 -

引用なし
パスワード
   ▼tantan さん:
こんにちは。

' 値が違ったら行挿入
Sub TEST1()
  Dim endRow As Long
  Dim i    As Long
  Dim lngT  As Long
  Dim tRow  As Long
  
  With Worksheets("Sheet1")
    'sheet1のA列のデータの最終行を求める
    endRow = .Range("A" & .Rows.Count).End(xlUp).Row
    tRow = endRow + 1
    ' 最終行から追加していく
    For i = endRow To 2 Step -1
      '前の行と値が違ったら行追加
      If .Cells(i, 1).Value <> .Cells(i - 1, 1).Value Then
        .Rows(tRow).Insert
        tRow = i
      End If
    Next
    ' 最初の行の処理
    .Rows(tRow).Insert
  End With
End Sub


' 最終行の次の行に合計
Sub TEST2()
  Dim endRow As Long
  
  With Worksheets("Sheet1")
    'sheet1のA列のデータの最終行を求める
    endRow = .Range("A" & .Rows.Count).End(xlUp).Row
    '最終行 + 1行目に合計       合計する範囲
    .Range("A" & endRow + 1).Value = Application.Sum(.Range("A1:A" & endRow))
  End With
End Sub

【59111】Re:マクロでのオートSUM
発言  Hirofumi  - 08/11/29(土) 8:14 -

引用なし
パスワード
   単純な方法は、A列を上から見て行って値が代わったら
行を挿入、挿入した行に数式を代入を繰り返すかな?
ただ此れだと非常に遅いので、データが多い場合は一考した方が善いと思いますよ

Option Explicit

Public Sub Sample()

  Dim i As Long
  Dim lngTop As Long
  
  '操作するシートを指定
  With ActiveSheet
    'データ先頭行位置を指定
    i = 1
    '先頭行位置を保存
    lngTop = i
    '2行目〜データが""に成る位置まで繰り返し
    i = i + 1
    Do Until .Cells(i, "A").Value = ""
      'もし、現在の値が前の値と違ったら
      If .Cells(i, "A").Value <> .Cells(i - 1, "A").Value Then
        '行を挿入
        .Cells(i, "A").EntireRow.Insert
        '数式を出力
        .Cells(i, "A").Formula _
            = "=Sum(A" & lngTop & ":A" & (i - 1) & ")"
        '行挿入を行った為操作行を更新
        i = i + 1
        '値が代わった位置を保存
        lngTop = i
      End If
      '操作行を更新
      i = i + 1
    Loop
    '最終データの数式を出力
    .Cells(i, "A").Formula _
        = "=Sum(A" & lngTop & ":A" & (i - 1) & ")"
  End With
  
End Sub

【59116】Re:マクロでのオートSUM
発言  Hirofumi  - 08/11/29(土) 11:46 -

引用なし
パスワード
   もう少し処理速度を上げるにはこんなかな?

Option Explicit

Public Sub Sample2()

  '◆データ列数(A列のみ)
  Const clngColumns As Long = 1
  
  Dim i As Long
  Dim lngRows As Long
  Dim rngList As Range
  Dim vntData As Variant
  Dim lngNumb() As Long
  Dim lngTop As Long
  Dim lngCount As Long
  Dim lngCalculation As Long
  Dim strProm As String

  '◆Listの先頭セル位置を基準とする
  Set rngList = ActiveSheet.Cells(1, "A")

  With rngList
    '行数の取得
    lngRows = .Offset(Rows.Count - .Row).End(xlUp).Row - .Row + 1
    If lngRows <= 1 And .Value = "" Then
      strProm = "データが有りません"
      GoTo Wayout
    End If
    '列データを配列に取得
    vntData = .Resize(lngRows + 1).Value
    '整列Keyを保存する配列を確保
    ReDim lngNumb(1 To lngRows + 1, 1 To 1)
  End With
  
  With Application
    '画面更新を停止
    .ScreenUpdating = False
    '再計算モードを保存
    lngCalculation = .Calculation
    '再計算モードを手動に設定
    .Calculation = xlCalculationManual
  End With
  
  With rngList
    '同一値の行数を初期値に
    lngCount = 1
    For i = 2 To lngRows + 1
      If vntData(i, 1) <> vntData(i - 1, 1) Then
        '整列Key値を更新
        lngNumb(i, 1) = lngNumb(i - 1, 1) + 1
        '最終行の下に数式を出力
        .Offset(lngRows).FormulaR1C1 = "=Sum(R[-" & (lngCount) & "]C:R[-1]C)"
        '整列Keyを出力
        .Offset(lngRows, clngColumns).Value = lngNumb(i, 1) - 1
        lngRows = lngRows + 1
        '先頭行位置を保存
        lngTop = i - 1
        '同一値の行数を初期値に
        lngCount = 1
      Else
        '同一値の行数を更新
        lngCount = lngCount + 1
        '整列Key値を代入
        lngNumb(i, 1) = lngNumb(i - 1, 1)
      End If
    Next i
    '整列Keyを出力
    .Offset(, clngColumns).Resize(UBound(lngNumb, 1) - 1).Value = lngNumb
    '整列Keyで行整列
    DataSort .Resize(lngRows, clngColumns + 1), .Offset(, clngColumns)
    '整列Keyを削除
    .Offset(, clngColumns).EntireColumn.Delete
  End With
  
  strProm = "処理が完了しました"
   
Wayout:
  
  With Application
    '再計算モードを元に戻す
    .Calculation = lngCalculation
    '再計算実行
    .Calculate
    '画面更新を再開
    .ScreenUpdating = True
  End With
  
  Set rngList = Nothing
   
  MsgBox strProm, vbInformation
     
End Sub

Private Sub DataSort(rngScope As Range, _
          rngKey As Range, _
          Optional lngOrientation As Long = xlTopToBottom)

  rngScope.Sort _
      Key1:=rngKey, Order1:=xlAscending, _
      Header:=xlNo, OrderCustom:=1, MatchCase:=False, _
      Orientation:=lngOrientation, SortMethod:=xlStroke

End Sub

【59130】Re:マクロでのオートSUM
質問  tantan  - 08/11/29(土) 23:06 -

引用なし
パスワード
   Yukiさん、hirofumiさんどうもありがとうございます。
教えていただいたものでうまくできそうです!!

ちなみにもう少し聞いてもよろしいですか?
行挿入とは別にオートSUMで実行するとして、
 1  
 1  1.左記の空白行にSUMで自動計算 
 1   させるにはどのようにしらた
    よいでしょうか?
 2   同じですかね??
 2

 3  2.単純に1の下をアクティブにして
 3   SUMマクロ実行。2の下を・・・
 3   とひとつずつやるにはどのように
     したらよいでしょうか?  
 4

2通り教えてください。
もう少しおつきあい下さいm(__)m

【59131】Re:マクロでのオートSUM
回答  Hirofumi  - 08/11/30(日) 0:18 -

引用なし
パスワード
   ▼tantan さん:
>Yukiさん、hirofumiさんどうもありがとうございます。
>教えていただいたものでうまくできそうです!!
>
>ちなみにもう少し聞いてもよろしいですか?
>行挿入とは別にオートSUMで実行するとして、
> 1  
> 1  1.左記の空白行にSUMで自動計算 
> 1   させるにはどのようにしらた
>    よいでしょうか?
> 2   同じですかね??
> 2
>
> 3  2.単純に1の下をアクティブにして
> 3   SUMマクロ実行。2の下を・・・
> 3   とひとつずつやるにはどのように
>     したらよいでしょうか?  
> 4
>
>2通り教えてください。
>もう少しおつきあい下さいm(__)m


SampleもSample2も行挿入を行って、其処にSumの数式を埋め込んで居ますが
それでは不都合が起きるのですか?

1はA列を上から見て行きながら空行まで行数を勘定し、
其れを元に数式を作成して代入と言う方法で
殆ど、Sampleと同じかな?

2はマクロの記録で出来るのでは?

【59132】Re:マクロでのオートSUM
回答  Hirofumi  - 08/11/30(日) 0:43 -

引用なし
パスワード
   因みに、1番はこんなかな?

Option Explicit

Public Sub Sample3()

  Dim i As Long
  Dim lngRows As Long
  Dim lngCount As Long
  
  '操作するシートを指定
  With ActiveSheet
    '最終行取得
    lngRows = .Cells(Rows.Count, "A").End(xlUp).Row
    '先頭行〜最終行+1まで繰り返し
    For i = 1 To lngRows + 1
      'もし、現在の値がEmptyなら
      If IsEmpty(.Cells(i, "A").Value) Then
        '数式を出力
        .Cells(i, "A").Formula _
            = "=Sum(R[-" & (lngCount) & "]C:R[-1]C)"
        '空白行までの行数を初期値に
        lngCount = 0
      Else
        '空白行までの行数をカウント
        lngCount = lngCount + 1
      End If
    Next i
  End With
  
End Sub

【59133】Re:マクロでのオートSUM
質問  tantan  - 08/11/30(日) 0:47 -

引用なし
パスワード
   ▼Hirofumi さん:
>
>SampleもSample2も行挿入を行って、其処にSumの数式を埋め込んで居ますが
>それでは不都合が起きるのですか?
>
>1はA列を上から見て行きながら空行まで行数を勘定し、
>其れを元に数式を作成して代入と言う方法で
>殆ど、Sampleと同じかな?
>
>2はマクロの記録で出来るのでは?

不都合はありません!私のやりたかったことが全部一気に
できていたので感動です!

ただ、Sampleをいただいたので基本的な考え方はわかったのですが、
もっと基本的なこと。。
2の場合はどうやるのかなぁ?と・・・疑問が。

最初の質問でも書いた通りマクロの記録でとると

ActiveCell.FormulaR1C1 = "=SUM(R[-3]C:R[-1]C)"
のような形となってしまうので、毎回変化する行数には
使えません。
単純にこのような場合でもSampleにいただいたような
やり方をしなければいけないのでしょうか?
基本的なことがわかってなくて申し訳ありません。。

【59134】Re:マクロでのオートSUM
回答  Hirofumi  - 08/11/30(日) 1:45 -

引用なし
パスワード
   >ただ、Sampleをいただいたので基本的な考え方はわかったのですが、
>もっと基本的なこと。。
>2の場合はどうやるのかなぁ?と・・・疑問が。
>
>最初の質問でも書いた通りマクロの記録でとると
>
>ActiveCell.FormulaR1C1 = "=SUM(R[-3]C:R[-1]C)"
>のような形となってしまうので、毎回変化する行数には
>使えません。
>単純にこのような場合でもSampleにいただいたような
>やり方をしなければいけないのでしょうか?
>基本的なことがわかってなくて申し訳ありません

もっと簡単な方法が有るのかも解りませんが?
私は、ここら辺が一番単純な方法では無いかと思っています
Do〜LoopやFor〜Nextを使って上から見て行く、
若しくは下から見て行くのが、速い遅いは別にして
一番解りやすい(応用範囲が広い)方法なのでは?

因みに、SampleをFor〜Nextで書き換えると、
Sample3のコードと殆ど同じに成ります


Public Sub Sample4()

  Dim i As Long
  Dim lngRows As Long
  Dim lngCount As Long
  Dim lngInsert As Long
  
  '操作するシートを指定
  With ActiveSheet
    '最終行取得
    lngRows = .Cells(Rows.Count, "A").End(xlUp).Row
    '同一値の行数を初期値に
    lngCount = 1
    '2行目〜最終行+1まで繰り返し
    For i = 2 To lngRows + 1
      'もし、現在の値が前の値と違ったら
      If .Cells(i + lngInsert, "A").Value _
          <> .Cells(i + lngInsert - 1, "A").Value Then
        .Cells(i + lngInsert, "A").EntireRow.Insert
        '数式を出力(前回、FormulaR1C1をFormulaと書いたのは間違い)
        .Cells(i + lngInsert, "A").FormulaR1C1 _
            = "=Sum(R[-" & (lngCount) & "]C:R[-1]C)"
        '同一値の行数を初期値に
        lngCount = 1
        '挿入行数を記録
        lngInsert = lngInsert + 1
      Else
        '同一値の行数を更新
        lngCount = lngCount + 1
      End If
    Next i
  End With
  
End Sub

【59151】Re:マクロでのオートSUM
質問  tantan  - 08/11/30(日) 18:54 -

引用なし
パスワード
   ▼Hirofumi さん:
ありがとうございます。当初の目的はおかげさまでできそうです。
ただ、今後のためにおしえてください。


エクセルでオートSUM「Σ」ボタンをクリックして、自動的に
範囲を決めるようなものはどうしたらよいでしょうか?
エクセルでは
   A B C
 1 =sum(B1:C1)
 2 2
 3 3
 4 □

エクセルでは□でオートSUM「Σ」をクリックするとA1は数式なので
自動的に「=sum(A2:A3)」をひろってくるはずです。
このようなものをマクロで実施するには・・・

Hirofumi さんのコードをつくり変えればできるかな?
と思ってみたのですが、途中でわからなくなってしまいました
もしよかったら教えてください。


Option Explicit

Public Sub Sample()

  Dim i As Long
  Dim lngTop As Long
  
  '操作するシートを指定
  With ActiveSheet
    'データ先頭行位置を指定
    i = ActiveCell.Row   ’変更
    '先頭行位置を保存
    lngTop = i

    '現在のセルより上のデータが数字でなくなるまで繰り返し
    i = i - 1
    Do Until .Cells(i, "A").Value = ""   ’←ここをどう変更すれば?
      'もし、現在の値が数字でなくなったら
      If Not IsNumeric.Cells(i, "A").Value Then  '???
        '数式を出力
        .Cells(i, "A").Formula _
            = "=Sum(A" & i & ":A" & (lngTop - 1) & ")"
      End If
      '操作行を更新
      i = i - 1
    Loop
   End With
  
End Sub

【59157】Re:マクロでのオートSUM
回答  Hirofumi  - 08/11/30(日) 20:48 -

引用なし
パスワード
   こんなのでは

Option Explicit

Public Sub Sample5()
'
  Dim i As Long
'  Dim lngTop As Long
  Dim lngCount As Long

'  '操作するシートを指定
'  With ActiveSheet
'    'データ先頭行位置を指定
'    i = ActiveCell.Row   '変更
'    '先頭行位置を保存
'    lngTop = i
'
'    '現在のセルより上のデータが数字でなくなるまで繰り返し
'    i = i - 1
'    Do Until .Cells(i, "A").Value = ""   '←ここをどう変更すれば?
'      'もし、現在の値が数字でなくなったら
'      If Not IsNumeric.Cells(i, "A").Value Then  '???
'        '数式を出力
'        .Cells(i, "A").Formula _
'            = "=Sum(A" & i & ":A" & (lngTop - 1) & ")"
'      End If
'      '操作行を更新
'      i = i - 1
'    Loop
'   End With

  'ActiveCellを基準とする
  With ActiveCell
    'データ行数の初期値を設定
    lngCount = 0
    '現在のセルより上のデータが数字でなくなるまで繰り返し
    i = i - 1
    Do Until .Row + i = 0
      '操作行が数値無く、若しくはEmpty値ならDoを抜ける
      If (Not IsNumeric(.Offset(i).Value)) Or IsEmpty(.Offset(i).Value) Then
        Exit Do
      Else
        'データ行数をカウント
        lngCount = lngCount + 1
      End If
      '操作行を更新
      i = i - 1
    Loop
    '数式を出力
    .FormulaR1C1 = "=Sum(R[-" & (lngCount) & "]C:R[-1]C)"
  End With
  
End Sub

【59166】Re:マクロでのオートSUM
質問  tantan  - 08/12/1(月) 0:28 -

引用なし
パスワード
   ▼Hirofumi さん:
早い対応ありがとうございます。

いただいたコード試させてもらいましたが、
数値、数式に関係なく一番下から上までの
総和となってしまいますよね?
Activecell行から上の「数値のみ」の合計を出していきたい
のですが。(Activecell行の一つ上の数値から数式が入力されて
いるセルの下まで)
うまくできないでしょうか?
私もいろいろと試してみたのですが、何ぶん勉強不足
なもので。。

長くなってしまい申し訳ありませんが、もう少し
よろしくお願いします。

【59168】Re:マクロでのオートSUM
発言  SS  - 08/12/1(月) 9:47 -

引用なし
パスワード
   ▼tantan さん:

質問通りの動きではなくActiveCellの下から全部を対象にしてですが
作ってみました。こんな感じで出来るのではないでしょうか。

Sub Macro1()
'
  Dim i As Long, j As Long, k As Long
  Dim txt
  With Selection
    k = .Column
    i = .Row + 1
    j = Cells(65536, k).End(xlUp).Row
    
    txt = Range(Cells(i, k).Address, Cells(j, k).Address).SpecialCells(xlCellTypeConstants, 1).Address
    .Formula = "=SUM(" & txt & ")"
  End With
End Sub

>▼Hirofumi さん:
>早い対応ありがとうございます。
>
>いただいたコード試させてもらいましたが、
>数値、数式に関係なく一番下から上までの
>総和となってしまいますよね?
>Activecell行から上の「数値のみ」の合計を出していきたい
>のですが。(Activecell行の一つ上の数値から数式が入力されて
>いるセルの下まで)
>うまくできないでしょうか?
>私もいろいろと試してみたのですが、何ぶん勉強不足
>なもので。。
>
>長くなってしまい申し訳ありませんが、もう少し
>よろしくお願いします。

【59195】Re:マクロでのオートSUM
質問  tantan  - 08/12/2(火) 0:57 -

引用なし
パスワード
   ▼SS さん:

ありがとうございます。
SpecialCellsメソッドを使って、値だけたす方法もあるのですね。
勉強になります。

ただ、SSさんが言うように入力範囲全部を対象になってしまってますね。
私は、アクティブセルの上の数字のみの一番小さな合計を求める
ものが知りたいのですが、やはり簡単にはいかないものなのでしょうか?

【59196】Re:マクロでのオートSUM
発言  ichinose  - 08/12/2(火) 8:09 -

引用なし
パスワード
   おはようございます


Findメソッドを使った方法です。


試してみてください。


Sub Macro1()
  Dim i As Long, j As Long, k As Long
  Dim target As Range
  With ActiveCell
    If .Row > 1 Then
      k = .Column
      i = .Row - 1
      If Range(Cells(1, k), Cells(i, k)).Count > 1 Then
       Set target = get_findcell("=", Range(Cells(1, k), Cells(i, k)), Cells(1, k), xlFormulas, xlPart, xlByColumns, xlPrevious)
       If target Is Nothing Then
         Set target = Cells(1, k)
       ElseIf target.Address <> Cells(i, k).Address Then
         Set target = target.Offset(1, 0)
       End If
      Else
       Set target = Cells(1, k)
      End If
      .Formula = "=sum(" & Range(target, Cells(i, k)).Address & ")"
    End If
  End With
End Sub
Function get_findcell(Optional ByVal f_v As Variant = "", _
           Optional ByVal rng As Range = Nothing, _
           Optional ByVal strng As Range = Nothing, _
           Optional ByVal alookin As XlFindLookIn = -4163, _
           Optional ByVal alookat As XlLookAt = 1, _
           Optional ByVal aso As XlSearchOrder = 1, _
           Optional ByVal asd As XlSearchDirection = 1, _
           Optional ByVal mc As Boolean = False, _
           Optional ByVal mb As Boolean = True) As Range
'指定された値でセル範囲を検索し、該当するセルを取得する
'input : f_v 検索する値
'    rng 検索する範囲
'    strng 検索開始セル
'    alookin 検索対象 xlvalues,xlformulas,xlcomments
'    alookat: :検索方法 1-完全一致 2-部分一致
'    aso : 検索順序 1 行 2 列
'    asd : 検索方向 1 Xlnext 2 XlPrevious
'    mc  : 大文字・小文字の区別 False しない True する
'    mb  : 半角と全角を区別   True する  False しない
'output:get_findcell 見つかったセル(見つからなかったときはNothingが返る)
  Dim 検索開始セル As Range
  Static 検索範囲 As Range
  Static 最初に見つかったセル As Range
  Static 直前に見つかったセル As Range
  Static 検索方向 As XlSearchDirection
  If Not rng Is Nothing Then
    Set 検索範囲 = rng
    End If
  If f_v <> "" Then
    If strng Is Nothing Then
     Set strng = 検索範囲.Cells(検索範囲.Rows.Count, 検索範囲.Columns.Count)
     
     End If
    Set get_findcell = 検索範囲.Find(f_v, strng, alookin, alookat, aso, asd)
    If Not get_findcell Is Nothing Then
     Set 最初に見つかったセル = get_findcell
     Set 直前に見つかったセル = get_findcell
     検索方向 = asd
     End If
  Else
    If 検索方向 = xlNext Then
     Set get_findcell = 検索範囲.FindNext(直前に見つかったセル)
    Else
     Set get_findcell = 検索範囲.FindPrevious(直前に見つかったセル)
     End If
    If get_findcell.Address = 最初に見つかったセル.Address Then
     Set get_findcell = Nothing
    Else
     Set 直前に見つかったセル = get_findcell
     End If
    End If
End Function

【59197】Re:マクロでのオートSUM
発言  Jaka  - 08/12/2(火) 9:33 -

引用なし
パスワード
   Function & Find
の組み合わせがでたのでここだけ一応。

エクセルのバージョンはなんでしょうか?
その辺も書かれていたほうが良いです。

【59224】Re:マクロでのオートSUM
回答  Hirofumi  - 08/12/2(火) 18:43 -

引用なし
パスワード
   >いただいたコード試させてもらいましたが、
>数値、数式に関係なく一番下から上までの
>総和となってしまいますよね?
>Activecell行から上の「数値のみ」の合計を出していきたい
>のですが。(Activecell行の一つ上の数値から数式が入力されて
>いるセルの下まで)
>うまくできないでしょうか?
>私もいろいろと試してみたのですが、何ぶん勉強不足
>なもので。。
>
>長くなってしまい申し訳ありませんが、もう少し
>よろしくお願いします。

変ですね?
どの様なデータで試されましたか?

当方では、Excel2000もExcel2007もActiveCellの行から上の
Empty値の在るセル、若しくは数字では無いセルの下までが範囲と成っていますが?
ただし、「Not IsNumeric(.Offset(i).Value)」と言う比較を使っていますので
文字列を返す数式、若しくは文字列で有っても、数字であった場合は範囲に含めてしまいます

【59225】Re:マクロでのオートSUM
回答  Hirofumi  - 08/12/2(火) 19:24 -

引用なし
パスワード
   後、やるとしたらこんなかなあ????


Public Sub Sample6()

  Dim i As Long
  Dim lngCount As Long
  Dim vntMark As Variant
  
  'ActiveCellを基準とする
  With ActiveCell
    'データ行数の初期値を設定
    lngCount = 0
    '現在のセルより上のデータが数字でなくなるまで繰り返し
    i = i - 1
    Do Until .Row + i = 0
      '操作行が数値無く、若しくはEmpty値ならDoを抜ける
      vntMark = .Offset(i).Value
      If VarType(vntMark) = vbDouble Or VarType(vntMark) = vbLong Then
        'データ行数をカウント
        lngCount = lngCount + 1
      Else
        Exit Do
      End If
      '操作行を更新
      i = i - 1
    Loop
    '該当行が無い場合
    If lngCount > 0 Then
      '数式を出力
      .FormulaR1C1 = "=Sum(R[-" & (lngCount) & "]C:R[-1]C)"
    End If
  End With
  
End Sub

【59228】Re:マクロでのオートSUM
発言  n  - 08/12/2(火) 21:24 -

引用なし
パスワード
   参考情報としての投稿です。
1行目に「見出し」があるなら[集計]機能が使える場合もあります。
ただしSUM関数ではなくSUBTOTAL関数になりますが。

Sub try1()
  Range("A1", Cells(Rows.Count, 1).End(xlUp).Offset(1)) _
    .Subtotal GroupBy:=1, Function:=xlSum, _
         TotalList:=Array(1), Replace:=True, _
         PageBreaks:=False, SummaryBelowData:=True
  Cells.ClearOutline
  'Columns("A").Delete
End Sub

空白セルを選択して[Σ]クリックという発想だとこんなのもあります。

Sub try2()
  Range("A1", Cells(Rows.Count, 1).End(xlUp).Offset(1)) _
    .SpecialCells(xlCellTypeBlanks).Select
  Application.CommandBars.FindControl(ID:=226).accDoDefaultAction
End Sub

最初のお題の
>1.行の挿入
>2.マクロでのオートSUM
に適用させるとしたら

Sub try3()
  Dim r As Range
  Dim x
  
  x = Range("A1").Value
  With Range("A1", Cells(Rows.Count, 1).End(xlUp)).Offset(1)
    For Each r In .Cells
      If r.Value <> x Then
        r.EntireRow.Insert
        x = r.Value
      End If
    Next
    .SpecialCells(xlCellTypeBlanks).Select
    Application.CommandBars.FindControl(ID:=226).accDoDefaultAction
    .Cells(.Count).ClearContents
  End With
End Sub

こんな感じ。
(#ごめんなさい。間違いあったので1回投稿削除しました)

【59262】Re:マクロでのオートSUM
お礼  tantan  - 08/12/4(木) 0:36 -

引用なし
パスワード
   ▼Hirofumi さん:

>変ですね?
>どの様なデータで試されましたか?
>
>当方では、Excel2000もExcel2007もActiveCellの行から上の
>Empty値の在るセル、若しくは数字では無いセルの下までが範囲と成っていますが?
>ただし、「Not IsNumeric(.Offset(i).Value)」と言う比較を使っていますので
>文字列を返す数式、若しくは文字列で有っても、数字であった場合は範囲に含めてしまいます


ありがとうございます。確かに、文字や漢字などを入力しているや空白セルの
下までの範囲となりました!
試したデータが、11/30の問でも書かせてもらったとおり、 
   A B C
 1 =sum(B1:C1)
 2 2
 3 3
 4 □

のようなデータで、=sum(B1:C1)の答えが10など数字が入るので
A1:A3までの総和15を返してしまったようですね。
数式を除く場合「Not IsNumeric(.Offset(i).Value)」を変更すれば
よいのでしょうか?HasFormula?

【59263】Re:マクロでのオートSUM
お礼  tantan  - 08/12/4(木) 0:41 -

引用なし
パスワード
   ▼ichinose さん:
ありがとうございます。
私がやりたかったことが、できていました!

Σをマクロで実施しようとするとこんなにも
難しいコードになるのですね。
当初、わりと簡単にできるものかと思ってました。
動くには動いたんですが、内容を理解するには
まだまだ、時間がかかりそうです。
もっと勉強します。
ありがとうございました!

【59264】Re:マクロでのオートSUM
質問  tantan  - 08/12/4(木) 1:50 -

引用なし
パスワード
   ▼n さん:
>空白セルを選択して[Σ]クリックという発想だとこんなのもあります。
>
>Sub try2()
>  Range("A1", Cells(Rows.Count, 1).End(xlUp).Offset(1)) _
>    .SpecialCells(xlCellTypeBlanks).Select
>  Application.CommandBars.FindControl(ID:=226).accDoDefaultAction
>End Sub

ありがとうございます。
とてもシンプルでいいなと思いました。
このような方法もあったんですね。
ただ、オートSUMのリストが出るところで止まってしまい、
Enterキーを押さなければいけませんが、全てを自動的に
することはできないでしょうか?
SendKeysでなんとかなるかな?と思い一番最後に
Application.SendKeys "{~}"
を付け足してみたのですが、だめでした。
何かよい方法はありますか?

【59265】Re:マクロでのオートSUM
発言  n  - 08/12/4(木) 3:06 -

引用なし
パスワード
   ガーん...
環境によっては確かにそうなりますね。
(CPU性能?私の非力なPCではいけるのですが)

すみませんでした...orz
SendKeysは不安定なので、やっぱりその案は忘れてください。

Sub TEST()
  With Range("A1", Cells(Rows.Count, 1).End(xlUp).Offset(1))
    .Cells(.Count).Value = Null
    .SpecialCells(xlCellTypeBlanks).Select
    SendKeys "~"
    Application.CommandBars.FindControl(ID:=226).Execute
  End With
End Sub

【59266】Re:マクロでのオートSUM
発言  ichinose  - 08/12/4(木) 6:22 -

引用なし
パスワード
   おはようございます。

>Σをマクロで実施しようとするとこんなにも
>難しいコードになるのですね。
いえ、そうではありません。

tantanさんが記述された仕様だけを満足させれば良いのであれば・・、

Sub Macro1()
  Dim i As Long, j As Long, k As Long
  Dim target As Range
  With ActiveCell
    If .Row > 1 Then
      k = .Column
      i = .Row - 1
      If Range(Cells(1, k), Cells(i, k)).Count > 1 Then
       Set target = Range(Cells(1, k), Cells(i, k)).Find("=", Cells(1, k), xlFormulas, xlPart, , xlPrevious)
       If target Is Nothing Then
         Set target = Cells(1, k)
       ElseIf target.Address <> Cells(i, k).Address Then
         Set target = target.Offset(1, 0)
       End If
      Else
       Set target = Cells(1, k)
      End If
      .Formula = "=sum(" & Range(target, Cells(i, k)).Address & ")"
    End If
  End With
End Sub

上記のコードでも同じように作動すると思いますよ!!

つまり、get_findcellというコードはなくても動作はします。


では何故わざわざ長いコードを???  ですよね!!


理由1 汎用サブルーチンの品質向上のため

get_findcellと言うコードは、かなり以前に作成したプロシジャーです。
tantanさんが記述された仕様のために作成したコードではありません。

もっともMacro1の方も直前の投稿コードを1/3ぐらい引用させてもらいましたので
私がtantanさんの仕様のために新たに書いたコードはMacro1の2/3ぐらいなんです。


get_findcellは、
Findメソッド関連の処理を私自身が使いやすいインターフェースにしたものです。

RangeオブジェクトのFindメソッドを使うと、
指定セル範囲内の特定の文字列があるセルを複数取得することができますが、
そのアルゴリズムを毎回記述するのが面倒で、この処理を汎用的 且つ、簡単な
インターフェースで行いたかったのです。

HelpにFindメソッドを使って複数のセルを取得するコード例がありますから
調べてみてください。

このget_findcellを作成後は、Findメソッド関連の処理には、このFunctionを使うようにしています。

今回のようにもっと簡単に記述できる仕様でも・・・です。

だって、色んな事象に使えば、get_findcellのテストをより多く行えるので
それによって完成度が増すでしょう?

言ってみれば、汎用Functionのデバッグをしてもらうためです。


理由2 拡張性の考慮

私は、プログラミングするときには、拡張性ということにかなり重点をおいて
プログラム構造を考えているつもりなんです。

つまり、将来こんな仕様の変更にも対応できるように とか、
今はないけど、将来こんな機能追加も考えられるなあ なんて、考えた時に
それを視野に入れたプログラム構造を考えると言うことです。

今回の仕様って、
言わば、Sum関数からSum関数の間の小計をとる仕様ですよね?

本来のExcelの仕様では、
小計を算出したら、中計、大計も算出できるようになっています。

これも実現できるようになんて、機能追加が発生した場合は、
関数が入っている複数のセルを取得可能にしなければならないなあ・・
と考えました。

その時のためにたいしたコード量でもないのでget_findcellで処理しておけば、
変更が楽かなあ と考えたためです。


シンプルなコードが駄目とは思いませんが、

シンプル IS Best だとは、私は思っていないんです。

【59283】Re:マクロでのオートSUM
回答  Hirofumi  - 08/12/4(木) 19:29 -

引用なし
パスワード
   Sample7は、数式が入っていた場合、Sumの範囲は数式の下の行からと成ります

Public Sub Sample7()

'  全ての数式を除く場合

  Dim i As Long
  Dim lngCount As Long
  Dim vntMark As Variant
  
  'ActiveCellを基準とする
  With ActiveCell
    'データ行数の初期値を設定
    lngCount = 0
    '現在のセルより上のデータが数字でなくなるまで繰り返し
    i = i - 1
    Do Until .Row + i = 0
      '操作行が数値無く、若しくはEmpty値ならDoを抜ける
      vntMark = .Offset(i).Value
      If .Offset(i).HasFormula = False _
          And (VarType(vntMark) = vbDouble _
              Or VarType(vntMark) = vbLong) Then
        'データ行数をカウント
        lngCount = lngCount + 1
      Else
        Exit Do
      End If
      '操作行を更新
      i = i - 1
    Loop
    '該当行が無い場合
    If lngCount > 0 Then
      '数式を出力
      .FormulaR1C1 = "=Sum(R[-" & (lngCount) & "]C:R[-1]C)"
    End If
  End With
  
End Sub

Sample8は、Sum数式が入っていた場合、Sumの範囲はSum数式の下の行からと成ります
ただし、他の数式の場合、数値を返している場合は範囲に含み、
それ以外を返している場合は、その下までと成ります

Public Sub Sample8()

'  Sumの数式と数値以外の数式を除く場合

  Dim i As Long
  Dim lngCount As Long
  Dim vntMark As Variant
  
  'ActiveCellを基準とする
  With ActiveCell
    'データ行数の初期値を設定
    lngCount = 0
    '現在のセルより上のデータが数字でなくなるまで繰り返し
    i = i - 1
    Do Until .Row + i = 0
      '操作行が数値無く、若しくはEmpty値ならDoを抜ける
      vntMark = .Offset(i).Value
      If InStr(1, .Offset(i).Formula, "=SUM", vbBinaryCompare) <> 1 _
          And (VarType(vntMark) = vbDouble _
              Or VarType(vntMark) = vbLong) Then
        'データ行数をカウント
        lngCount = lngCount + 1
      Else
        Exit Do
      End If
      '操作行を更新
      i = i - 1
    Loop
    '該当行が無い場合
    If lngCount > 0 Then
      '数式を出力
      .FormulaR1C1 = "=Sum(R[-" & (lngCount) & "]C:R[-1]C)"
    End If
  End With
  
End Sub

【59310】Re:マクロでのオートSUM
お礼  tantan  - 08/12/5(金) 18:06 -

引用なし
パスワード
   ▼Hirofumi さん:
丁寧な対応ありがとうございます。
みなさんのおかげで、できました。

私も早く自由にマクロが組みたいです。
また、よろしくお願いします。

【59311】Re:マクロでのオートSUM
お礼  tantan  - 08/12/5(金) 18:08 -

引用なし
パスワード
   ▼n さん:
ありがとうございます。
マクロってPC環境によって変わるのですね。。

今回はちゃんとできました。
ありがとうございました。今後もよろしくおねがいします。

3951 / 13644 ツリー ←次へ | 前へ→
ページ:  ┃  記事番号:
2610219
(SS)C-BOARD v3.8 is Free